1N/A# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ 1N/A chdir 't' if -d 't'; 1N/A print "1..0 # Skip: no SDBM_File\n"; 1N/A#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT 1N/Aif ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin') { 1N/A print "ok 2 # Skipped: different file permission semantics\n"; 1N/A my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 1N/A print (($mode & 0777) == ($^O eq 'vos' ? 0750 : 0640) ? "ok 2\n" : "not ok 2\n"); 1N/Aprint (!$i ? "ok 3\n" : "not ok 3\n");
1N/A$h{
'goner1'} =
'snork';
1N/A$h{
'jkl',
'mno'} =
"JKL\034MNO";
1N/A$h{
'a',
2,
3,
4,
5} =
join("\034",'A',2,3,4,5);
1N/A$h{
'goner2'} =
'snork';
1N/Aprint (tie(%h,'SDBM_File','Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
1N/A$h{
'goner3'} =
'snork';
1N/Aif ($#keys == 29 && $#values == 29) {
print "ok 5\n";}
else {
print "not ok 5\n";}
1N/Aif ($i == 30) {
print "ok 6\n";}
else {
print "not ok 6\n";}
1N/Aif ($#keys == 31) {
print "ok 7\n";}
else {
print "not ok 7\n";}
1N/A# check cache overflow and numeric keys and contents 1N/Afor ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } 1N/Afor ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } 1N/Aprint ($ok ? "ok 8\n" : "not ok 8\n");
1N/Amy ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 1N/Aprint ($size > 0 ? "ok 9\n" : "not ok 9\n");
1N/A@h{
0..
200} =
200..
400;
1N/Aprint ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
1N/Aprint ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
1N/A eval 'use SubDB ; use Fcntl ;'; 1N/A $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 ); 1N/A my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; 1N/A $ret = eval '$X->A_new_method("fred") ' ; 1N/A $h{"fred"} = "joe" ; 1N/A # replace the filters, but remember the previous set 1N/A $h{"Fred"} = "Joe" ; 1N/A # put the original filters back 1N/A $h{"fred"} = "joe" ; 1N/A # delete the filters 1N/A $h{"fred"} = "joe" ; 1N/A # DBM Filter with a closure 1N/A $h{"fred"} = "joe" ; 1N/A $h{"jim"} = "john" ; 1N/A # DBM Filter recursion detection 1N/A eval '$h{1} = 1234' ; 1N/A # Bug ID 20001013.009 1N/A # test that $hash{KEY} = undef doesn't produce the warning 1N/A # Use of uninitialized value in null operation 1N/A # When iterating over a tied hash using "each", the key passed to FETCH 1N/A # will be recycled and passed to NEXTKEY. If a Source Filter modifies the 1N/A # key in FETCH via a filter_fetch_key method we need to check that the 1N/A # modified key doesn't get passed to NEXTKEY. 1N/A # Also Test "keys" & "values" while we are at it. 1N/A $h{'Alpha_ABC'} = 2 ; 1N/A $h{'Alpha_DEF'} = 5 ; 1N/A ok(70, $h{'Alpha_ABC'} == 2); 1N/A ok(71, $h{'Alpha_DEF'} == 5); 1N/A my ($k, $v) = ("",""); 1N/A # Check that DBM Filter can cope with read-only $_ 1N/A $h{"fred"} = "joe" ; 1N/A eval { grep { $h{$_} } (1, 2, 3) }; 1N/A # delete the filters 1N/A $h{"fred"} = "joe" ; 1N/A eval { grep { $h{$_} } (1, 2, 3) };