1#!perl
2BEGIN {
3}
4
5use strict;
6use warnings;
7
8use Test::More;
9use Config;
10
11our $DBM_Class;
12
13my ($create, $write);
14BEGIN {
15    plan(skip_all => "$DBM_Class was not built")
16	unless $Config{extensions} =~ /\b$DBM_Class\b/;
17    plan(skip_all => "$DBM_Class not compatible with C++")
18	 if $DBM_Class eq 'ODBM_File' && $Config{d_cplusplus};
19
20    use_ok($DBM_Class);
21
22    if ($::Create_and_Write) {
23	($create, $write) = eval $::Create_and_Write;
24	isnt($create, undef, "(eval q{$::Create_and_Write})[0]");
25	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	use_ok('Fcntl');
29	$create = O_RDWR()|O_CREAT();
30	$write = O_RDWR();
31    }
32}
33
34unlink <Op_dbmx.*>;
35
36umask(0);
37my %h;
38isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class);
39
40my $Dfile = "Op_dbmx.pag";
41if (! -e $Dfile) {
42	($Dfile) = <Op_dbmx*>;
43}
44SKIP: {
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';
47    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
48	$blksize,$blocks) = stat($Dfile);
49    is($mode & 0777, 0640);
50}
51my $i = 0;
52while (my ($key,$value) = each(%h)) {
53    $i++;
54}
55is($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';
74delete $h{'goner2'};
75
76untie(%h);
77isa_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
99delete $h{'goner1'};
100delete $h{'goner3'};
101
102my @keys = keys(%h);
103my @values = values(%h);
104
105is($#keys, 29);
106is($#values, 29);
107
108while (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
115is($i, 30);
116
117@keys = ('blurfl', keys(%h), 'dyick');
118is($#keys, 31);
119
120$h{'foo'} = '';
121$h{''} = 'bar';
122
123my $ok = 1;
124for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
125for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
126is($ok, 1, 'check cache overflow and numeric keys and contents');
127
128my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
129   $blksize,$blocks) = stat($Dfile);
130cmp_ok($size, '>', 0);
131
132@h{0..200} = 200..400;
133my @foo = @h{0..200};
134is(join(':',200..400), join(':',@foo));
135
136is($h{'foo'}, '');
137is($h{''}, 'bar');
138
139if($DBM_Class eq 'SDBM_File') {
140    is(exists $h{goner1}, '');
141    is(exists $h{foo}, 1);
142}
143
144untie %h;
145unlink <Op_dbmx*>, $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;
188EOM
189
190    close $file or die "Could not close: $!";
191
192    BEGIN { push @INC, '.'; }
193    unlink <dbhash_tmp*>;
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", <dbhash_tmp*>;
221
222}
223
224untie %h;
225unlink <Op_dbmx*>, $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       my($fk, $sk, $fv, $sv) = @_;
235       local $Test::Builder::Level = $Test::Builder::Level + 1;
236       is($fetch_key, $fk);
237       is($store_key, $sk);
238       is($fetch_value, $fv);
239       is($store_value, $sv);
240       is($_, 'original');
241   }
242
243   unlink <Op_dbmx*>;
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 <Op_dbmx*>;
332}
333
334{
335    # DBM Filter with a closure
336
337    my (%h, $db);
338
339    unlink <Op_dbmx*>;
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        my ($name) = @_;
348	my $count = 0;
349	my @kept = ();
350
351	return sub { ++$count;
352		     push @kept, $_;
353		     $result{$name} = "$name - $count: [@kept]";
354		   }
355    }
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 <Op_dbmx*>;
395}
396
397{
398   # DBM Filter recursion detection
399   my (%h, $db);
400   unlink <Op_dbmx*>;
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 <Op_dbmx*>;
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 <Op_dbmx*>;
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 <Op_dbmx*>;
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 <Op_dbmx*>;
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 <Op_dbmx*>;
469}
470
471{
472   # Check that DBM Filter can cope with read-only $_
473
474   my %h;
475   unlink <Op1_dbmx*>;
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 <Op1_dbmx*>;
512}
513
514done_testing();
5151;
516