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' || $^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);
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) = @_;
235 local $Test::Builder::Level = $Test::Builder::Level + 1;
238 is($fetch_value, $fv);
239 is($store_value, $sv);
244 $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
245 isa_ok($db, $DBM_Class);
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 = $_ });
256 checkOutput("", "fred", "", "joe");
258 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
259 is($h{"fred"}, "joe");
261 checkOutput("", "fred", "joe", "");
263 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
264 is($db->FIRSTKEY(), "fred");
266 checkOutput("fred", "", "", "");
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 = $_ });
278 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
281 checkOutput("", "fred", "", "Jxe");
283 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
284 is($h{"Fred"}, "[Jxe]");
286 checkOutput("", "fred", "[Jxe]", "");
288 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
289 is($db->FIRSTKEY(), "FRED");
291 checkOutput("FRED", "", "", "");
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);
299 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
301 checkOutput("", "fred", "", "joe");
303 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
304 is($h{"fred"}, "joe");
305 checkOutput("", "fred", "joe", "");
307 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
308 is($db->FIRSTKEY(), "fred");
309 checkOutput("fred", "", "", "");
312 $db->filter_fetch_key (undef);
313 $db->filter_store_key (undef);
314 $db->filter_fetch_value (undef);
315 $db->filter_store_value (undef);
317 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
319 checkOutput("", "", "", "");
321 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
322 is($h{"fred"}, "joe");
323 checkOutput("", "", "", "");
325 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
326 is($db->FIRSTKEY(), "fred");
327 checkOutput("", "", "", "");
335 # DBM Filter with a closure
340 $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
341 isa_ok($db, $DBM_Class);
351 return sub { ++$count;
353 $result{$name} = "$name - $count: [@kept]";
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"));
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);
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);
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);
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]");
398 # DBM Filter recursion detection
402 $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
403 isa_ok($db, $DBM_Class);
405 $db->filter_store_key (sub { $_ = $h{$_} });
408 like($@, qr/^recursion detected in filter_store_key at/);
416 # Bug ID 20001013.009
418 # test that $hash{KEY} = undef doesn't produce the warning
419 # Use of uninitialized value in null operation
424 local $SIG{__WARN__} = sub {$a = $_[0]};
426 isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class);
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.
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_/});
451 is($h{'Alpha_ABC'}, 2);
452 is($h{'Alpha_DEF'}, 5);
454 my ($k, $v) = ("", "");
455 while (($k, $v) = each %h) {}
459 foreach $k (keys %h) {}
463 foreach $v (values %h) {}
472 # Check that DBM Filter can cope with read-only $_
477 my $db = tie %h, $DBM_Class, 'Op1_dbmx', $create, 0640;
478 isa_ok($db, $DBM_Class);
480 $db->filter_fetch_key (sub { });
481 $db->filter_store_key (sub { });
482 $db->filter_fetch_value (sub { });
483 $db->filter_store_value (sub { });
488 is($h{"fred"}, "joe");
490 is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
495 $db->filter_fetch_key (undef);
496 $db->filter_store_key (undef);
497 $db->filter_fetch_value (undef);
498 $db->filter_store_value (undef);
502 is($h{"fred"}, "joe");
504 is($db->FIRSTKEY(), "fred");
506 is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);