File Coverage

/home/pjcj/g/Test-Smoke/perl-current-gcov/t/lib/dbmt_common.pl
Criterion Covered Total %
statement 35 38 92.1
branch 3 6 50.0
condition 1 3 33.3
subroutine 10 10 100.0
total 49 57 86.0


line stmt bran cond sub time code
1           #!perl
2 1     1 111625 BEGIN {
3           }
4            
5 1     1 9 use strict;
  1       3  
  1       40  
6 1     1 6 use warnings;
  1       3  
  1       36  
7            
8 1     1 472 use Test::More;
  1       21434  
  1       11  
9 1     1 373 use Config;
  1       3  
  1       311  
10            
11           our $DBM_Class;
12            
13           my ($create, $write);
14           BEGIN {
15 1 50   1 15 plan(skip_all => "$DBM_Class was not built")
16           unless $Config{extensions} =~ /\b$DBM_Class\b/;
17 1 50 33   8 plan(skip_all => "$DBM_Class not compatible with C++")
18           if $DBM_Class eq 'ODBM_File' && $Config{d_cplusplus};
19            
20 1       4 use_ok($DBM_Class);
21            
22 1 50     2974 if ($::Create_and_Write) {
23 0       0 ($create, $write) = eval $::Create_and_Write;
24 0       0 isnt($create, undef, "(eval q{$::Create_and_Write})[0]");
25 0       0 isnt($write, undef, "(eval q{$::Create_and_Write})[1]");
26           } else {
27           #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
28 1       6 use_ok('Fcntl');
29 1       967 $create = O_RDWR()|O_CREAT();
30 1       1425 $write = O_RDWR();
31           }
32           }
33            
34           unlink ;
35            
36           umask(0);
37           my %h;
38           isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class);
39            
40           my $Dfile = "Op_dbmx.pag";
41           if (! -e $Dfile) {
42           ($Dfile) = ;
43           }
44           SKIP: {
45           skip "different file permission semantics on $^O", 1
46           if $^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin' || $^O eq 'vos';
47           my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
48           $blksize,$blocks) = stat($Dfile);
49           is($mode & 0777, 0640);
50           }
51           my $i = 0;
52           while (my ($key,$value) = each(%h)) {
53           $i++;
54           }
55           is($i, 0);
56            
57           $h{'goner1'} = 'snork';
58            
59           $h{'abc'} = 'ABC';
60           $h{'def'} = 'DEF';
61           $h{'jkl','mno'} = "JKL\034MNO";
62           $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
63           $h{'a'} = 'A';
64           $h{'b'} = 'B';
65           $h{'c'} = 'C';
66           $h{'d'} = 'D';
67           $h{'e'} = 'E';
68           $h{'f'} = 'F';
69           $h{'g'} = 'G';
70           $h{'h'} = 'H';
71           $h{'i'} = 'I';
72            
73           $h{'goner2'} = 'snork';
74           delete $h{'goner2'};
75            
76           untie(%h);
77           isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $write, 0640), $DBM_Class);
78            
79           $h{'j'} = 'J';
80           $h{'k'} = 'K';
81           $h{'l'} = 'L';
82           $h{'m'} = 'M';
83           $h{'n'} = 'N';
84           $h{'o'} = 'O';
85           $h{'p'} = 'P';
86           $h{'q'} = 'Q';
87           $h{'r'} = 'R';
88           $h{'s'} = 'S';
89           $h{'t'} = 'T';
90           $h{'u'} = 'U';
91           $h{'v'} = 'V';
92           $h{'w'} = 'W';
93           $h{'x'} = 'X';
94           $h{'y'} = 'Y';
95           $h{'z'} = 'Z';
96            
97           $h{'goner3'} = 'snork';
98            
99           delete $h{'goner1'};
100           delete $h{'goner3'};
101            
102           my @keys = keys(%h);
103           my @values = values(%h);
104            
105           is($#keys, 29);
106           is($#values, 29);
107            
108           while (my ($key, $value) = each(%h)) {
109           if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
110           $key =~ y/a-z/A-Z/;
111           $i++ if $key eq $value;
112           }
113           }
114            
115           is($i, 30);
116            
117           @keys = ('blurfl', keys(%h), 'dyick');
118           is($#keys, 31);
119            
120           $h{'foo'} = '';
121           $h{''} = 'bar';
122            
123           my $ok = 1;
124           for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
125           for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
126           is($ok, 1, 'check cache overflow and numeric keys and contents');
127            
128           my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
129           $blksize,$blocks) = stat($Dfile);
130           cmp_ok($size, '>', 0);
131            
132           @h{0..200} = 200..400;
133           my @foo = @h{0..200};
134           is(join(':',200..400), join(':',@foo));
135            
136           is($h{'foo'}, '');
137           is($h{''}, 'bar');
138            
139           if($DBM_Class eq 'SDBM_File') {
140           is(exists $h{goner1}, '');
141           is(exists $h{foo}, 1);
142           }
143            
144           untie %h;
145           unlink , $Dfile;
146            
147           {
148           # sub-class test
149            
150           package Another;
151            
152           open my $file, '>', 'SubDB.pm' or die "Cannot open SubDB.pm: $!\n";
153           printf $file <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class;
154            
155           package SubDB;
156            
157           use strict;
158           use warnings;
159           use vars qw(@ISA @EXPORT);
160            
161           require Exporter;
162           use %s;
163           @ISA=qw(%s);
164           @EXPORT = @%s::EXPORT;
165            
166           sub STORE {
167           my $self = shift;
168           my $key = shift;
169           my $value = shift;
170           $self->SUPER::STORE($key, $value * 2);
171           }
172            
173           sub FETCH {
174           my $self = shift;
175           my $key = shift;
176           $self->SUPER::FETCH($key) - 1;
177           }
178            
179           sub A_new_method
180           {
181           my $self = shift;
182           my $key = shift;
183           my $value = $self->FETCH($key);
184           return "[[$value]]";
185           }
186            
187           1;
188           EOM
189            
190           close $file or die "Could not close: $!";
191            
192 1     1 3927 BEGIN { push @INC, '.'; }
193           unlink ;
194            
195           main::use_ok('SubDB');
196           my %h;
197           my $X;
198           eval '
199           $X = tie(%h, "SubDB", "dbhash_tmp", $create, 0640 );
200           ';
201            
202           main::is($@, "");
203            
204           my $ret = eval '$h{"fred"} = 3; return $h{"fred"} ';
205           main::is($@, "");
206           main::is($ret, 5);
207            
208           $ret = eval '$X->A_new_method("fred") ';
209           main::is($@, "");
210           main::is($ret, "[[5]]");
211            
212           if ($DBM_Class eq 'GDBM_File') {
213           $ret = eval 'GDBM_WRCREAT eq main::GDBM_WRCREAT';
214           main::is($@, "");
215           main::is($ret, 1);
216           }
217            
218           undef $X;
219           untie(%h);
220           unlink "SubDB.pm", ;
221            
222           }
223            
224           untie %h;
225           unlink , $Dfile;
226            
227           {
228           # DBM Filter tests
229           my (%h, $db);
230           my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
231            
232           sub checkOutput
233           {
234 12     12 35 my($fk, $sk, $fv, $sv) = @_;
235 12       26 local $Test::Builder::Level = $Test::Builder::Level + 1;
236 12       35 is($fetch_key, $fk);
237 12       4035 is($store_key, $sk);
238 12       4054 is($fetch_value, $fv);
239 12       4058 is($store_value, $sv);
240 12       4032 is($_, 'original');
241           }
242            
243           unlink ;
244           $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
245           isa_ok($db, $DBM_Class);
246            
247           $db->filter_fetch_key (sub { $fetch_key = $_ });
248           $db->filter_store_key (sub { $store_key = $_ });
249           $db->filter_fetch_value (sub { $fetch_value = $_});
250           $db->filter_store_value (sub { $store_value = $_ });
251            
252           $_ = "original";
253            
254           $h{"fred"} = "joe";
255           # fk sk fv sv
256           checkOutput("", "fred", "", "joe");
257            
258           ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
259           is($h{"fred"}, "joe");
260           # fk sk fv sv
261           checkOutput("", "fred", "joe", "");
262            
263           ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
264           is($db->FIRSTKEY(), "fred");
265           # fk sk fv sv
266           checkOutput("fred", "", "", "");
267            
268           # replace the filters, but remember the previous set
269           my ($old_fk) = $db->filter_fetch_key
270           (sub { $_ = uc $_; $fetch_key = $_ });
271           my ($old_sk) = $db->filter_store_key
272           (sub { $_ = lc $_; $store_key = $_ });
273           my ($old_fv) = $db->filter_fetch_value
274           (sub { $_ = "[$_]"; $fetch_value = $_ });
275           my ($old_sv) = $db->filter_store_value
276           (sub { s/o/x/g; $store_value = $_ });
277            
278           ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
279           $h{"Fred"} = "Joe";
280           # fk sk fv sv
281           checkOutput("", "fred", "", "Jxe");
282            
283           ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
284           is($h{"Fred"}, "[Jxe]");
285           # fk sk fv sv
286           checkOutput("", "fred", "[Jxe]", "");
287            
288           ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
289           is($db->FIRSTKEY(), "FRED");
290           # fk sk fv sv
291           checkOutput("FRED", "", "", "");
292            
293           # put the original filters back
294           $db->filter_fetch_key ($old_fk);
295           $db->filter_store_key ($old_sk);
296           $db->filter_fetch_value ($old_fv);
297           $db->filter_store_value ($old_sv);
298            
299           ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
300           $h{"fred"} = "joe";
301           checkOutput("", "fred", "", "joe");
302            
303           ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
304           is($h{"fred"}, "joe");
305           checkOutput("", "fred", "joe", "");
306            
307           ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
308           is($db->FIRSTKEY(), "fred");
309           checkOutput("fred", "", "", "");
310            
311           # delete the filters
312           $db->filter_fetch_key (undef);
313           $db->filter_store_key (undef);
314           $db->filter_fetch_value (undef);
315           $db->filter_store_value (undef);
316            
317           ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
318           $h{"fred"} = "joe";
319           checkOutput("", "", "", "");
320            
321           ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
322           is($h{"fred"}, "joe");
323           checkOutput("", "", "", "");
324            
325           ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
326           is($db->FIRSTKEY(), "fred");
327           checkOutput("", "", "", "");
328            
329           undef $db;
330           untie %h;
331           unlink ;
332           }
333            
334           {
335           # DBM Filter with a closure
336            
337           my (%h, $db);
338            
339           unlink ;
340           $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
341           isa_ok($db, $DBM_Class);
342            
343           my %result = ();
344            
345           sub Closure
346           {
347 4     4 12 my ($name) = @_;
348 4       7 my $count = 0;
349 4       6 my @kept = ();
350            
351 7     7 30 return sub { ++$count;
352 7       17 push @kept, $_;
353 7       79 $result{$name} = "$name - $count: [@kept]";
354           }
355 4       27 }
356            
357           $db->filter_store_key(Closure("store key"));
358           $db->filter_store_value(Closure("store value"));
359           $db->filter_fetch_key(Closure("fetch key"));
360           $db->filter_fetch_value(Closure("fetch value"));
361            
362           $_ = "original";
363            
364           $h{"fred"} = "joe";
365           is($result{"store key"}, "store key - 1: [fred]");
366           is($result{"store value"}, "store value - 1: [joe]");
367           is($result{"fetch key"}, undef);
368           is($result{"fetch value"}, undef);
369           is($_, "original");
370            
371           is($db->FIRSTKEY(), "fred");
372           is($result{"store key"}, "store key - 1: [fred]");
373           is($result{"store value"}, "store value - 1: [joe]");
374           is($result{"fetch key"}, "fetch key - 1: [fred]");
375           is($result{"fetch value"}, undef);
376           is($_, "original");
377            
378           $h{"jim"} = "john";
379           is($result{"store key"}, "store key - 2: [fred jim]");
380           is($result{"store value"}, "store value - 2: [joe john]");
381           is($result{"fetch key"}, "fetch key - 1: [fred]");
382           is($result{"fetch value"}, undef);
383           is($_, "original");
384            
385           is($h{"fred"}, "joe");
386           is($result{"store key"}, "store key - 3: [fred jim fred]");
387           is($result{"store value"}, "store value - 2: [joe john]");
388           is($result{"fetch key"}, "fetch key - 1: [fred]");
389           is($result{"fetch value"}, "fetch value - 1: [joe]");
390           is($_, "original");
391            
392           undef $db;
393           untie %h;
394           unlink ;
395           }
396            
397           {
398           # DBM Filter recursion detection
399           my (%h, $db);
400           unlink ;
401            
402           $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
403           isa_ok($db, $DBM_Class);
404            
405           $db->filter_store_key (sub { $_ = $h{$_} });
406            
407           eval '$h{1} = 1234';
408           like($@, qr/^recursion detected in filter_store_key at/);
409            
410           undef $db;
411           untie %h;
412           unlink ;
413           }
414            
415           {
416           # Bug ID 20001013.009
417           #
418           # test that $hash{KEY} = undef doesn't produce the warning
419           # Use of uninitialized value in null operation
420            
421           unlink ;
422           my %h;
423           my $a = "";
424           local $SIG{__WARN__} = sub {$a = $_[0]};
425            
426           isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class);
427           $h{ABC} = undef;
428           is($a, "");
429           untie %h;
430           unlink ;
431           }
432            
433           {
434           # When iterating over a tied hash using "each", the key passed to FETCH
435           # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
436           # key in FETCH via a filter_fetch_key method we need to check that the
437           # modified key doesn't get passed to NEXTKEY.
438           # Also Test "keys" & "values" while we are at it.
439            
440           unlink ;
441           my $bad_key = 0;
442           my %h = ();
443           my $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
444           isa_ok($db, $DBM_Class);
445           $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_});
446           $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/; $_ =~ s/^Alpha_/Beta_/});
447            
448           $h{'Alpha_ABC'} = 2;
449           $h{'Alpha_DEF'} = 5;
450            
451           is($h{'Alpha_ABC'}, 2);
452           is($h{'Alpha_DEF'}, 5);
453            
454           my ($k, $v) = ("", "");
455           while (($k, $v) = each %h) {}
456           is($bad_key, 0);
457            
458           $bad_key = 0;
459           foreach $k (keys %h) {}
460           is($bad_key, 0);
461            
462           $bad_key = 0;
463           foreach $v (values %h) {}
464           is($bad_key, 0);
465            
466           undef $db;
467           untie %h;
468           unlink ;
469           }
470            
471           {
472           # Check that DBM Filter can cope with read-only $_
473            
474           my %h;
475           unlink ;
476            
477           my $db = tie %h, $DBM_Class, 'Op1_dbmx', $create, 0640;
478           isa_ok($db, $DBM_Class);
479            
480           $db->filter_fetch_key (sub { });
481           $db->filter_store_key (sub { });
482           $db->filter_fetch_value (sub { });
483           $db->filter_store_value (sub { });
484            
485           $_ = "original";
486            
487           $h{"fred"} = "joe";
488           is($h{"fred"}, "joe");
489            
490           is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
491           is($@, '');
492            
493            
494           # delete the filters
495           $db->filter_fetch_key (undef);
496           $db->filter_store_key (undef);
497           $db->filter_fetch_value (undef);
498           $db->filter_store_value (undef);
499            
500           $h{"fred"} = "joe";
501            
502           is($h{"fred"}, "joe");
503            
504           is($db->FIRSTKEY(), "fred");
505            
506           is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
507           is($@, '');
508            
509           undef $db;
510           untie %h;
511           unlink ;
512           }
513            
514           done_testing();
515           1;