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};
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]");
27 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
29 $create = O_RDWR()|O_CREAT();
38 isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class);
40 my $Dfile = "Op_dbmx.pag";
42 ($Dfile) = <Op_dbmx*>;
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);
52 while (my ($key,$value) = each(%h)) {
57 $h{'goner1'} = 'snork';
61 $h{'jkl','mno'} = "JKL\034MNO";
62 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
73 $h{'goner2'} = 'snork';
77 isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $write, 0640), $DBM_Class);
97 $h{'goner3'} = 'snork';
103 my @values = values(%h);
108 while (my ($key, $value) = each(%h)) {
109 if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
111 $i++ if $key eq $value;
117 @keys = ('blurfl', keys(%h), 'dyick');
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');
128 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
129 $blksize,$blocks) = stat($Dfile);
130 cmp_ok($size, '>', 0);
132 @h{0..200} = 200..400;
133 my @foo = @h{0..200};
134 is(join(':',200..400), join(':',@foo));
139 if($DBM_Class eq 'SDBM_File') {
140 is(exists $h{goner1}, '');
141 is(exists $h{foo}, 1);
145 unlink <Op_dbmx*>, $Dfile;
152 open my $file, '>', 'SubDB.pm' or die "Cannot open SubDB.pm: $!\n";
153 printf $file <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class;
159 use vars qw(@ISA @EXPORT);
164 @EXPORT = @%s::EXPORT;
170 $self->SUPER::STORE($key, $value * 2);
176 $self->SUPER::FETCH($key) - 1;
183 my $value = $self->FETCH($key);
190 close $file or die "Could not close: $!";
192 BEGIN { push @INC, '.'; }
193 unlink <dbhash_tmp*>;
195 main::use_ok('SubDB');
199 $X = tie(%h, "SubDB", "dbhash_tmp", $create, 0640 );
204 my $ret = eval '$h{"fred"} = 3; return $h{"fred"} ';
208 $ret = eval '$X->A_new_method("fred") ';
210 main::is($ret, "[[5]]");
212 if ($DBM_Class eq 'GDBM_File') {
213 $ret = eval 'GDBM_WRCREAT eq main::GDBM_WRCREAT';
220 unlink "SubDB.pm", <dbhash_tmp.*>;
225 unlink <Op_dbmx*>, $Dfile;
230 my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
234 my($fk, $sk, $fv, $sv) = @_;
236 $fetch_key eq $fk && $store_key eq $sk &&
237 $fetch_value eq $fv && $store_value eq $sv &&
242 $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
243 isa_ok($db, $DBM_Class);
245 $db->filter_fetch_key (sub { $fetch_key = $_ });
246 $db->filter_store_key (sub { $store_key = $_ });
247 $db->filter_fetch_value (sub { $fetch_value = $_});
248 $db->filter_store_value (sub { $store_value = $_ });
254 ok(checkOutput("", "fred", "", "joe"));
256 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
257 is($h{"fred"}, "joe");
259 ok(checkOutput("", "fred", "joe", ""));
261 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
262 is($db->FIRSTKEY(), "fred");
264 ok(checkOutput("fred", "", "", ""));
266 # replace the filters, but remember the previous set
267 my ($old_fk) = $db->filter_fetch_key
268 (sub { $_ = uc $_; $fetch_key = $_ });
269 my ($old_sk) = $db->filter_store_key
270 (sub { $_ = lc $_; $store_key = $_ });
271 my ($old_fv) = $db->filter_fetch_value
272 (sub { $_ = "[$_]"; $fetch_value = $_ });
273 my ($old_sv) = $db->filter_store_value
274 (sub { s/o/x/g; $store_value = $_ });
276 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
279 ok(checkOutput("", "fred", "", "Jxe"));
281 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
282 is($h{"Fred"}, "[Jxe]");
284 ok(checkOutput("", "fred", "[Jxe]", ""));
286 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
287 is($db->FIRSTKEY(), "FRED");
289 ok(checkOutput("FRED", "", "", ""));
291 # put the original filters back
292 $db->filter_fetch_key ($old_fk);
293 $db->filter_store_key ($old_sk);
294 $db->filter_fetch_value ($old_fv);
295 $db->filter_store_value ($old_sv);
297 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
299 ok(checkOutput("", "fred", "", "joe"));
301 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
302 is($h{"fred"}, "joe");
303 ok(checkOutput("", "fred", "joe", ""));
305 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
306 is($db->FIRSTKEY(), "fred");
307 ok(checkOutput("fred", "", "", ""));
310 $db->filter_fetch_key (undef);
311 $db->filter_store_key (undef);
312 $db->filter_fetch_value (undef);
313 $db->filter_store_value (undef);
315 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
317 ok(checkOutput("", "", "", ""));
319 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
320 is($h{"fred"}, "joe");
321 ok(checkOutput("", "", "", ""));
323 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
324 is($db->FIRSTKEY(), "fred");
325 ok(checkOutput("", "", "", ""));
333 # DBM Filter with a closure
338 $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
339 isa_ok($db, $DBM_Class);
349 return sub { ++$count;
351 $result{$name} = "$name - $count: [@kept]";
355 $db->filter_store_key(Closure("store key"));
356 $db->filter_store_value(Closure("store value"));
357 $db->filter_fetch_key(Closure("fetch key"));
358 $db->filter_fetch_value(Closure("fetch value"));
363 is($result{"store key"}, "store key - 1: [fred]");
364 is($result{"store value"}, "store value - 1: [joe]");
365 is($result{"fetch key"}, undef);
366 is($result{"fetch value"}, undef);
369 is($db->FIRSTKEY(), "fred");
370 is($result{"store key"}, "store key - 1: [fred]");
371 is($result{"store value"}, "store value - 1: [joe]");
372 is($result{"fetch key"}, "fetch key - 1: [fred]");
373 is($result{"fetch value"}, undef);
377 is($result{"store key"}, "store key - 2: [fred jim]");
378 is($result{"store value"}, "store value - 2: [joe john]");
379 is($result{"fetch key"}, "fetch key - 1: [fred]");
380 is($result{"fetch value"}, undef);
383 is($h{"fred"}, "joe");
384 is($result{"store key"}, "store key - 3: [fred jim fred]");
385 is($result{"store value"}, "store value - 2: [joe john]");
386 is($result{"fetch key"}, "fetch key - 1: [fred]");
387 is($result{"fetch value"}, "fetch value - 1: [joe]");
396 # DBM Filter recursion detection
400 $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
401 isa_ok($db, $DBM_Class);
403 $db->filter_store_key (sub { $_ = $h{$_} });
406 like($@, qr/^recursion detected in filter_store_key at/);
414 # Bug ID 20001013.009
416 # test that $hash{KEY} = undef doesn't produce the warning
417 # Use of uninitialized value in null operation
422 local $SIG{__WARN__} = sub {$a = $_[0]};
424 isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class);
432 # When iterating over a tied hash using "each", the key passed to FETCH
433 # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
434 # key in FETCH via a filter_fetch_key method we need to check that the
435 # modified key doesn't get passed to NEXTKEY.
436 # Also Test "keys" & "values" while we are at it.
441 my $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
442 isa_ok($db, $DBM_Class);
443 $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_});
444 $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/; $_ =~ s/^Alpha_/Beta_/});
449 is($h{'Alpha_ABC'}, 2);
450 is($h{'Alpha_DEF'}, 5);
452 my ($k, $v) = ("", "");
453 while (($k, $v) = each %h) {}
457 foreach $k (keys %h) {}
461 foreach $v (values %h) {}
470 # Check that DBM Filter can cope with read-only $_
475 my $db = tie %h, $DBM_Class, 'Op1_dbmx', $create, 0640;
476 isa_ok($db, $DBM_Class);
478 $db->filter_fetch_key (sub { });
479 $db->filter_store_key (sub { });
480 $db->filter_fetch_value (sub { });
481 $db->filter_store_value (sub { });
486 is($h{"fred"}, "joe");
488 is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
493 $db->filter_fetch_key (undef);
494 $db->filter_store_key (undef);
495 $db->filter_fetch_value (undef);
496 $db->filter_store_value (undef);
500 is($h{"fred"}, "joe");
502 is($db->FIRSTKEY(), "fred");
504 is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);