File Coverage

blib/lib/Tie/Array/DBD.pm
Criterion Covered Total %
statement 213 266 80.0
branch 98 128 76.5
condition 10 17 58.8
subroutine 27 47 57.4
pod 1 1 100.0
total 349 459 76.0


line stmt bran cond sub pod time code
1             package Tie::Array::DBD;
2              
3             our $VERSION = "0.24";
4              
5 24     24   335529 use strict;
  24         61  
  24         674  
6 24     24   138 use warnings;
  24         70  
  24         580  
7              
8 24     24   121 use Carp;
  24         46  
  24         1360  
9              
10 24     24   13522 use DBI;
  24         149631  
  24         88288  
11              
12             my $dbdx = sprintf "%04d", (time + int rand 10000) % 10000;
13              
14             my %DB = (
15             Pg => {
16             temp => "temp",
17             t_key => "bigint not null primary key",
18             t_val => "bytea",
19             clear => "truncate table",
20             autoc => 0,
21             },
22             Unify => {
23             temp => "",
24             t_key => "numeric (9) not null primary key",
25             t_val => "binary",
26             clear => "delete from",
27             },
28             Oracle => {
29             temp => "global temporary", # Only as of Ora-9
30             t_key => "number (38) not null primary key",
31             t_val => "blob",
32             clear => "truncate table",
33             autoc => 0,
34             },
35             MariaDB => {
36             temp => "temporary",
37             t_key => "bigint not null primary key",
38             t_val => "blob",
39             clear => "truncate table",
40             autoc => 0,
41             },
42             mysql => {
43             temp => "temporary",
44             t_key => "bigint not null primary key",
45             t_val => "blob",
46             clear => "truncate table",
47             autoc => 0,
48             },
49             SQLite => {
50             temp => "temporary",
51             t_key => "integer not null primary key",
52             t_val => "blob",
53             clear => "delete from",
54             pbind => 0, # TYPEs in SQLite are text, bind_param () needs int
55             autoc => 0,
56             },
57             CSV => {
58             temp => "temporary",
59             t_key => "integer not null primary key",
60             t_val => "text",
61             clear => "delete from",
62             },
63             Firebird => {
64             temp => "",
65             t_key => "integer primary key",
66             t_val => "varchar (8192)",
67             clear => "delete from",
68             },
69             );
70              
71             sub _create_table {
72 12     12   83 my ($cnf, $tmp) = @_;
73 12         34 $cnf->{tmp} = $tmp;
74              
75 12         31 my $dbh = $cnf->{dbh};
76 12         22 my $dbt = $cnf->{dbt};
77              
78 12         25 my $exists = 0;
79 12         41 eval {
80 12         141 local $dbh->{PrintError} = 0;
81 12         414 my $sth = $dbh->prepare ("select $cnf->{f_k}, $cnf->{f_v} from $cnf->{tbl}");
82 6         29789 $sth->execute;
83 0         0 $cnf->{tmp} = 0;
84 0         0 $exists = 1;
85             };
86 12 50       15519 $exists and return; # Table already exists
87              
88 12         485 my $temp = $DB{$dbt}{temp};
89 12 50       45 $cnf->{tmp} or $temp = "";
90 12 100 66     93 local $dbh->{AutoCommit} = 1 unless $dbt eq "CSV" || $dbt eq "Unify";
91 12         233 $dbh->do (
92             "create $temp table $cnf->{tbl} (".
93             "$cnf->{f_k} $cnf->{ktp},".
94             "$cnf->{f_v} $cnf->{vtp})"
95             );
96 12 50       24224 $dbt eq "Unify" and $dbh->commit;
97             } # create table
98              
99             sub TIEARRAY {
100 48     48   364008 my $pkg = shift;
101 48         166 my $usg = qq{usage: tie \@a, "$pkg", \$dbh [, { tbl => "tbl", key => "f_key", fld => "f_value" }];};
102 48 50       188 my $dsn = shift or croak $usg;
103 48         114 my $opt = shift;
104              
105 48 50       470 my $dbh = ref $dsn
    50          
106             ? $dsn->clone
107             : DBI->connect ($dsn, undef, undef, {
108             PrintError => 1,
109             RaiseError => 1,
110             PrintWarn => 0,
111             FetchHashKeyName => "NAME_lc",
112             }) or croak DBI->errstr;
113              
114 44   50     57035 my $dbt = $dbh->{Driver}{Name} || "no DBI handle";
115 44 50       502 my $cnf = $DB{$dbt} or croak "I don't support database '$dbt'";
116 44         92 my $f_k = "h_key";
117 44         82 my $f_v = "h_value";
118 44         79 my $tmp = 0;
119              
120 44         284 $dbh->{PrintWarn} = 0;
121 44 100       454 $dbh->{AutoCommit} = $cnf->{autoc} if exists $cnf->{autoc};
122 44 50       195 $dbh->{LongReadLen} = 4_194_304 if $dbt eq "Oracle";
123              
124             my $h = {
125             dbt => $dbt,
126             dbh => $dbh,
127             tbl => undef,
128             tmp => $tmp,
129             ktp => $cnf->{t_key},
130             vtp => $cnf->{t_val},
131              
132 44         349 _en => undef,
133             _de => undef,
134             };
135              
136 44 100       152 if ($opt) {
137 42 50       143 ref $opt eq "HASH" or croak $usg;
138              
139 42 50       122 $opt->{key} and $f_k = $opt->{key};
140 42 50       125 $opt->{fld} and $f_v = $opt->{fld};
141 42 50       100 $opt->{tbl} and $h->{tbl} = $opt->{tbl};
142 42 50       99 $opt->{vtp} and $h->{vtp} = $opt->{vtp};
143              
144 42 100       138 if (my $str = $opt->{str}) {
145 40 100       382 if ($str eq "Sereal") {
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
146 4         51 require Sereal::Encoder;
147 4         22 require Sereal::Decoder;
148 4         53 my $se = Sereal::Encoder->new;
149 4         48 my $sd = Sereal::Decoder->new;
150 4     312   44 $h->{_en} = sub { $se->encode ($_[0]) };
  312         1447  
151 4     880   23 $h->{_de} = sub { $sd->decode ($_[0]) };
  880         4787  
152             }
153             elsif ($str eq "Storable") {
154 4         30 require Storable;
155 4     312   30 $h->{_en} = sub { Storable::nfreeze ({ val => $_[0] }) };
  312         1105  
156 4     880   19 $h->{_de} = sub { Storable::thaw ($_[0])->{val} };
  880         2137  
157             }
158             elsif ($str eq "FreezeThaw") {
159 4         769 require FreezeThaw;
160 0     0   0 $h->{_en} = sub { FreezeThaw::freeze ($_[0]) };
  0         0  
161 0     0   0 $h->{_de} = sub { (FreezeThaw::thaw ($_[0]))[0] };
  0         0  
162             }
163             elsif ($str eq "JSON") {
164 4         1112 require JSON;
165 0         0 my $j = JSON->new->allow_nonref;
166 0     0   0 $h->{_en} = sub { $j->utf8->encode ($_[0]) };
  0         0  
167 0     0   0 $h->{_de} = sub { $j->decode ($_[0]) };
  0         0  
168             }
169             elsif ($str eq "JSON::Syck") {
170 4         902 require JSON::Syck;
171 0     0   0 $h->{_en} = sub { JSON::Syck::Dump ($_[0]) };
  0         0  
172 0     0   0 $h->{_de} = sub { JSON::Syck::Load ($_[0]) };
  0         0  
173             }
174             elsif ($str eq "YAML") {
175 4         903 require YAML;
176 0     0   0 $h->{_en} = sub { YAML::Dump ($_[0]) };
  0         0  
177 0     0   0 $h->{_de} = sub { YAML::Load ($_[0]) };
  0         0  
178             }
179             elsif ($str eq "YAML::Syck") {
180 4         844 require YAML::Syck;
181 0     0   0 $h->{_en} = sub { YAML::Syck::Dump ($_[0]) };
  0         0  
182 0     0   0 $h->{_de} = sub { YAML::Syck::Load ($_[0]) };
  0         0  
183             }
184             elsif ($str eq "Data::Dumper") {
185 0         0 require Data::Dumper;
186 0     0   0 $h->{_en} = sub { Data::Dumper::Dumper ($_[0]) };
  0         0  
187 0     0   0 $h->{_de} = sub { eval $_[0] };
  0         0  
188             }
189             elsif ($str eq "XML::Dumper") {
190 4         885 require XML::Dumper;
191 0         0 my $xd = XML::Dumper->new;
192 0     0   0 $h->{_en} = sub { $xd->pl2xml ($_[0]) };
  0         0  
193 0     0   0 $h->{_de} = sub { $xd->xml2pl ($_[0]) };
  0         0  
194             }
195             elsif ($str eq "Bencode") {
196 4         857 require Bencode;
197 0     0   0 $h->{_en} = sub { Bencode::bencode ($_[0]) };
  0         0  
198 0     0   0 $h->{_de} = sub { Bencode::bdecode ($_[0]) };
  0         0  
199             }
200             else {
201 4         770 croak "Unsupported serializer: $str\n";
202             }
203             }
204             }
205              
206 12         56 $h->{f_k} = $f_k;
207 12         35 $h->{f_v} = $f_v;
208              
209 12 50       40 unless ($h->{tbl}) { # Create a temporary table
210 12         38 $tmp = ++$dbdx;
211 12         89 $h->{tbl} = "t_tie_dbda_$$" . "_$tmp";
212             }
213 12         53 _create_table ($h, $tmp);
214 12         62 _setmax ($h);
215              
216 12         504 my $tbl = $h->{tbl};
217              
218 12         119 $h->{ins} = $dbh->prepare ("insert into $tbl ($f_k, $f_v) values (?, ?)");
219 12         11052 $h->{del} = $dbh->prepare ("delete from $tbl where $f_k = ?");
220 12         11442 $h->{upd} = $dbh->prepare ("update $tbl set $f_v = ? where $f_k = ?");
221 12         10623 $h->{sel} = $dbh->prepare ("select $f_v from $tbl where $f_k = ?");
222 12         8327 $h->{cnt} = $dbh->prepare ("select count(*) from $tbl");
223 12         4881 $h->{ctv} = $dbh->prepare ("select count(*) from $tbl where $f_k = ?");
224 12         7945 $h->{uky} = $dbh->prepare ("update $tbl set $f_k = ? where $f_k = ?");
225              
226 12 100 66     10439 unless (exists $cnf->{pbind} && !$cnf->{pbind}) {
227 6         49 my $sth = $dbh->prepare ("select $f_k, $f_v from $tbl where 0 = 1");
228 6         8864 $sth->execute;
229 6         5157 my @typ = @{$sth->{TYPE}};
  6         41  
230              
231 6         3437 $h->{ins}->bind_param (1, undef, $typ[0]);
232 6         91 $h->{ins}->bind_param (2, undef, $typ[1]);
233 6         70 $h->{del}->bind_param (1, undef, $typ[0]);
234 6         68 $h->{upd}->bind_param (1, undef, $typ[1]);
235 6         62 $h->{upd}->bind_param (2, undef, $typ[0]);
236 6         80 $h->{sel}->bind_param (1, undef, $typ[0]);
237 6         64 $h->{ctv}->bind_param (1, undef, $typ[0]);
238 6         59 $h->{uky}->bind_param (1, undef, $typ[0]);
239 6         67 $h->{uky}->bind_param (2, undef, $typ[0]);
240             }
241              
242 12         696 bless $h, $pkg;
243             } # TIEARRAY
244              
245             sub _stream {
246 780     780   1304 my ($self, $val) = @_;
247 780 50       1607 defined $val or return undef;
248              
249 780 100       1993 $self->{_en} and return $self->{_en}->($val);
250 156         296 return $val;
251             } # _stream
252              
253             sub _unstream {
254 2200     2200   4078 my ($self, $val) = @_;
255 2200 50       4238 defined $val or return undef;
256              
257 2200 100       5402 $self->{_de} and return $self->{_de}->($val);
258 440         1754 return $val;
259             } # _unstream
260              
261             sub _setmax {
262 22     22   61 my $self = shift;
263 22         184 my $sth = $self->{dbh}->prepare ("select max($self->{f_k}) from $self->{tbl}");
264 22         13384 $sth->execute;
265 22 50       10833 if (my $r = $sth->fetch) {
266 22 100       549 $self->{max} = defined $r->[0] ? $r->[0] : -1;
267             }
268             else {
269 0         0 $self->{max} = -1;
270             }
271 22         209 $self->{max};
272             } # _setmax
273              
274             sub STORE {
275 780     780   9033 my ($self, $key, $value) = @_;
276 780         1692 my $v = $self->_stream ($value);
277             $self->EXISTS ($key)
278             ? $self->{upd}->execute ($v, $key)
279 780 100       12909 : $self->{ins}->execute ($key, $v);
280 780 100       193383 $key > $self->{max} and $self->{max} = $key;
281             } # STORE
282              
283             sub DELETE {
284 160     160   366 my ($self, $key) = @_;
285 160         1272 $self->{sel}->execute ($key);
286 160 50       75274 my $r = $self->{sel}->fetch or return;
287 160         3810 $self->{del}->execute ($key);
288 160 100       73528 $key >= $self->{max} and $self->_setmax;
289 160         841 $self->_unstream ($r->[0]);
290             } # DELETE
291              
292             sub STORESIZE {
293 30     30   7212 my ($self, $size) = @_; # $size = $# + 1
294 30         67 $size--;
295 30         309 $self->{dbh}->do ("delete from $self->{tbl} where $self->{f_k} > $size");
296 30         38327 $self->{max} = $size;
297             } # STORESIZE
298              
299             sub CLEAR {
300 100     100   11945 my $self = shift;
301 100         891 $self->{dbh}->do ("$DB{$self->{dbt}}{clear} $self->{tbl}");
302 100         82591 $self->{max} = -1;
303             } # CLEAR
304              
305             sub EXISTS {
306 800     800   1376 my ($self, $key) = @_;
307 800 100       6398 $key <= $self->{max} or return 0;
308 130         1108 $self->{sel}->execute ($key);
309 130 100       52732 return $self->{sel}->fetch ? 1 : 0;
310             } # EXISTS
311              
312             sub FETCH {
313 2060     2060   8532 my ($self, $key) = @_;
314 2060 50       4593 $key <= $self->{max} or return undef;
315 2060         13377 $self->{sel}->execute ($key);
316 2060 100       981163 my $r = $self->{sel}->fetch or return;
317 2040         40255 $self->_unstream ($r->[0]);
318             } # STORE
319              
320             sub PUSH {
321 20     20   68 my ($self, @val) = @_;
322 20         54 for (@val) {
323 30         91 $self->STORE (++$self->{max}, $_);
324             }
325 20         77 return $self->FETCHSIZE;
326             } # PUSH
327              
328             sub POP {
329 10     10   36 my $self = shift;
330 10 50       54 $self->{max} >= 0 or return;
331 10         45 $self->DELETE ($self->{max});
332             } # POP
333              
334             sub SHIFT {
335 10     10   30 my $self = shift;
336 10         36 my $val = $self->DELETE (0);
337 10         291 $self->{uky}->execute ($_ - 1, $_) for 1 .. $self->{max};
338 10         11719 $self->{max}--;
339 10         61 return $val;
340             } # SHIFT
341              
342             sub UNSHIFT {
343 20     20   99 my ($self, @val) = @_;
344 20 50       79 @val or return;
345 20         44 my $incr = scalar @val;
346 20         445 $self->{uky}->execute ($_ + $incr, $_) for reverse 0 .. $self->{max};
347 20         26801 $self->{max} += $incr;
348 20         106 $self->STORE ($_, $val[$_]) for 0 .. $#val;
349 20         80 return $self->FETCHSIZE;
350             } # UNSHIFT
351              
352             # splice ARRAY, OFFSET, LENGTH, LIST
353             # splice ARRAY, OFFSET, LENGTH
354             # splice ARRAY, OFFSET
355             # splice ARRAY
356             #
357             # Removes the elements designated by OFFSET and LENGTH from an array, and
358             # replaces them with the elements of LIST, if any.
359             #
360             # In list context, returns the elements removed from the array.
361             # In scalar context, returns the last element removed, or "undef" if
362             # no elements are removed.
363             #
364             # The array grows or shrinks as necessary.
365             #
366             # If OFFSET is negative then it starts that far from the end of the array.
367             # If LENGTH is omitted, removes everything from OFFSET onward.
368             # If LENGTH is negative, removes the elements from OFFSET onward except for
369             # -LENGTH elements at the end of the array.
370             # If both OFFSET and LENGTH are omitted, removes everything.
371             # If OFFSET is past the end of the array, Perl issues a warning, and splices
372             # at the end of the array.
373              
374             sub SPLICE {
375 150     150   378 my $nargs = $#_;
376 150         369 my ($self, $off, $len, @new, @val) = @_;
377              
378             # splice @array;
379 150 100       400 if ($nargs == 0) {
380 20 100       69 if (wantarray) {
381 10         48 @val = map { $self->FETCH ($_) } 0 .. $self->{max};
  100         753  
382 10         115 $self->CLEAR;
383 10         132 return @val;
384             }
385 10         44 $val[0] = $self->FETCH ($self->{max});
386 10         124 $self->CLEAR;
387 10         98 return $val[0];
388             }
389              
390             # Take care of negative offset, count from tail
391 130 100       332 $off < 0 and $off = $self->{max} + 1 + $off;
392 130 100       1922 $off < 0 and
393             croak "Modification of non-creatable array value attempted, subscript $_[1]";
394              
395             # splice @array, off;
396 120 100       265 if ($nargs == 1) {
397 30 100       133 $off > $self->{max} and return;
398              
399 20 100       70 if (wantarray) {
400 10         42 @val = map { $self->FETCH ($_) } $off .. $self->{max};
  30         202  
401 10         118 $self->STORESIZE ($off);
402 10         99 return @val;
403             }
404 10         59 $val[0] = $self->FETCH ($self->{max});
405 10         139 $self->STORESIZE ($off);
406 10         80 return $val[0];
407             }
408              
409             # splice @array, off, len;
410 90 100 100     537 $nargs == 2 && $off > $self->{max} and return;
411              
412 60 100       204 my $last = $len < 0 ? $self->{max} + $len : $off + $len - 1;
413 60 50 66     246 $nargs == 2 && $last > $self->{max} and return $self->SPLICE ($off);
414              
415 60         161 @val = map { $self->DELETE ($_) } $off .. $last;
  130         850  
416 60         535 $len = @val;
417 60         1216 $self->{uky}->execute ($_ - $len, $_) for ($last + 1) .. $self->{max};
418 60         107234 $self->{max} -= $len;
419              
420             # splice @array, off, len, replacement-list;
421 60 100       186 if (@new) {
422 20         45 my $new = @new;
423 20         346 $self->{uky}->execute ($_ + $new, $_) for reverse $off .. $self->{max};
424 20         36535 $self->STORE ($off + $_, $new[$_]) for 0..$#new;
425 20         60 $self->{max} += $new;
426             }
427              
428 60 100       513 return wantarray ? @val : $val[-1];
429             } # SPLICE
430              
431             sub FIRSTKEY {
432 0     0   0 my $self = shift;
433 0 0       0 $self->{max} >= 0 or return;
434 0         0 $self->{min} = 0;
435             } # FIRSTKEY
436              
437             sub NEXTKEY {
438 0     0   0 my $self = shift;
439 0 0 0     0 exists $self->{min} && $self->{min} < $self->{max} and return ++$self->{min};
440 0         0 delete $self->{min};
441 0         0 return;
442             } # FIRSTKEY
443              
444             sub FETCHSIZE {
445 2150     2150   121472 my $self = shift;
446 2150         5303 return $self->{max} + 1;
447             } # FETCHSIZE
448              
449       70     sub EXTEND {
450             # no-op
451             } # EXTEND
452              
453             sub drop {
454 0     0 1 0 my $self = shift;
455 0         0 $self->{tmp} = 1;
456             } # drop
457              
458             sub _dump_table {
459 0     0   0 my $self = shift;
460 0         0 my $sth = $self->{dbh}->prepare ("select $self->{f_k}, $self->{f_v} from $self->{tbl} order by $self->{f_k}");
461 0         0 $sth->execute;
462 0         0 $sth->bind_columns (\my ($k, $v));
463 0         0 while ($sth->fetch) {
464 0         0 printf STDERR "%6d: '%s'\n", $k, $self->_unstream ($v);
465             }
466             } # _dump_table
467              
468             sub DESTROY {
469 12     12   69 my $self = shift;
470 12 50       142 my $dbh = $self->{dbh} or return;
471 12         86 for (qw( sel ins upd del cnt ctv uky )) {
472 84 50       234 $self->{$_} or next;
473 84         313 $self->{$_}->finish;
474 84         750 undef $self->{$_}; # DESTROY handle
475 84         3542 delete $self->{$_};
476             }
477 12         123 delete $self->{$_} for qw( _de _en );
478 12 50       59 if ($self->{tmp}) {
479 12 100       1472 $dbh->{AutoCommit} or $dbh->rollback;
480 12         220 $dbh->do ("drop table ".$self->{tbl});
481             }
482 12 100       94271 $dbh->{AutoCommit} or $dbh->commit;
483 12         785 $dbh->disconnect;
484 12         344 undef $dbh;
485 12         468 undef $self->{dbh};
486             } # DESTROY
487              
488             1;
489              
490             __END__