This eliminates 1445 lines, ie almost 500 lines duplicated fourfold.
t/lib/compmod.pl Helper for 1_compile.t
t/lib/croak.t Test calls to Perl_croak() in the C source.
t/lib/cygwin.t Builtin cygwin function tests
+t/lib/dbmt_common.pl Common functionality for ?DBM_File tests
t/lib/deprecate/Deprecated.pm Deprecated module to test deprecate.pm
t/lib/deprecate/Optionally.pm Optionally deprecated module to test deprecate.pm
t/lib/deprecate.t Test deprecate.pm
#!./perl
-# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+$::Create_and_Write = '(GDBM_WRCREAT, GDBM_WRITER)';
+our $DBM_Class = 'GDBM_File';
-our $DBM_Class;
-
-BEGIN {
- $DBM_Class = 'GDBM_File';
-}
-
-BEGIN {
- require Config; import Config;
- if ($Config{'extensions'} !~ /\b$DBM_Class\b/) {
- print "1..0 # Skip: $DBM_Class was not built\n";
- exit 0;
- }
-}
-
-use strict;
-use warnings;
-
-use Test::More tests => 84;
-BEGIN {use_ok($DBM_Class)};
-
-unlink <Op_dbmx.*>;
-
-umask(0);
-my %h ;
-isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', GDBM_WRCREAT, 0640), $DBM_Class);
-
-my $Dfile = "Op_dbmx.pag";
-if (! -e $Dfile) {
- ($Dfile) = <Op_dbmx*>;
-}
-SKIP: {
- skip "different file permission semantics on $^O", 1
- if $^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin';
- my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
- $blksize,$blocks) = stat($Dfile);
- is($mode & 0777, 0640);
-}
-my $i = 0;
-while (my ($key,$value) = each(%h)) {
- $i++;
-}
-is($i, 0);
-
-$h{'goner1'} = 'snork';
-
-$h{'abc'} = 'ABC';
-$h{'def'} = 'DEF';
-$h{'jkl','mno'} = "JKL\034MNO";
-$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
-$h{'a'} = 'A';
-$h{'b'} = 'B';
-$h{'c'} = 'C';
-$h{'d'} = 'D';
-$h{'e'} = 'E';
-$h{'f'} = 'F';
-$h{'g'} = 'G';
-$h{'h'} = 'H';
-$h{'i'} = 'I';
-
-$h{'goner2'} = 'snork';
-delete $h{'goner2'};
-
-untie(%h);
-isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', GDBM_WRITER, 0640), $DBM_Class);
-
-$h{'j'} = 'J';
-$h{'k'} = 'K';
-$h{'l'} = 'L';
-$h{'m'} = 'M';
-$h{'n'} = 'N';
-$h{'o'} = 'O';
-$h{'p'} = 'P';
-$h{'q'} = 'Q';
-$h{'r'} = 'R';
-$h{'s'} = 'S';
-$h{'t'} = 'T';
-$h{'u'} = 'U';
-$h{'v'} = 'V';
-$h{'w'} = 'W';
-$h{'x'} = 'X';
-$h{'y'} = 'Y';
-$h{'z'} = 'Z';
-
-$h{'goner3'} = 'snork';
-
-delete $h{'goner1'};
-delete $h{'goner3'};
-
-my @keys = keys(%h);
-my @values = values(%h);
-
-is($#keys, 29);
-is($#values, 29);
-
-while (my ($key,$value) = each(%h)) {
- if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
- $key =~ y/a-z/A-Z/;
- $i++ if $key eq $value;
- }
-}
-
-is($i, 30);
-
-@keys = ('blurfl', keys(%h), 'dyick');
-is($#keys, 31);
-
-$h{'foo'} = '';
-$h{''} = 'bar';
-
-my $ok = 1;
-for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
-for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
-is($ok, 1, 'check cache overflow and numeric keys and contents');
-
-my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
- $blksize,$blocks) = stat($Dfile);
-cmp_ok($size, '>', 0);
-
-@h{0..200} = 200..400;
-my @foo = @h{0..200};
-is(join(':',200..400), join(':',@foo));
-
-is($h{'foo'}, '');
-is($h{''}, 'bar');
-
-untie %h;
-unlink <Op_dbmx*>, $Dfile;
-
-{
- # sub-class test
-
- package Another ;
-
- open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
- printf FILE <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class;
-
- package SubDB ;
-
- use strict ;
- use warnings ;
- use vars qw(@ISA @EXPORT) ;
-
- require Exporter ;
- use %s;
- @ISA=qw(%s);
- @EXPORT = @%s::EXPORT ;
-
- sub STORE {
- my $self = shift ;
- my $key = shift ;
- my $value = shift ;
- $self->SUPER::STORE($key, $value * 2) ;
- }
-
- sub FETCH {
- my $self = shift ;
- my $key = shift ;
- $self->SUPER::FETCH($key) - 1 ;
- }
-
- sub A_new_method
- {
- my $self = shift ;
- my $key = shift ;
- my $value = $self->FETCH($key) ;
- return "[[$value]]" ;
- }
-
- 1 ;
-EOM
-
- close FILE or die "Could not close: $!";
-
- BEGIN { push @INC, '.'; }
- unlink <dbhash_tmp*> ;
-
- eval 'use SubDB ; ';
- main::is($@, "");
- my %h ;
- my $X ;
- eval '
- $X = tie(%h, "SubDB","dbhash_tmp", &GDBM_WRCREAT, 0640 );
- ' ;
-
- main::is($@, "");
-
- my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
- main::is($@, "");
- main::is($ret, 5);
-
- $ret = eval ' &GDBM_WRCREAT eq &main::GDBM_WRCREAT ' ;
- main::is($@, "");
- main::is($ret, 1);
-
- $ret = eval '$X->A_new_method("fred") ' ;
- main::is($@, "");
- main::is($ret, "[[5]]");
-
- undef $X;
- untie(%h);
- unlink "SubDB.pm", <dbhash_tmp.*> ;
-
-}
-
-untie %h;
-unlink <Op_dbmx*>, $Dfile;
-
-{
- # DBM Filter tests
- my (%h, $db) ;
- my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
-
- sub checkOutput
- {
- my($fk, $sk, $fv, $sv) = @_ ;
- return
- $fetch_key eq $fk && $store_key eq $sk &&
- $fetch_value eq $fv && $store_value eq $sv &&
- $_ eq 'original' ;
- }
-
- unlink <Op_dbmx*>;
- $db = tie %h, $DBM_Class, 'Op_dbmx', GDBM_WRCREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
- $db->filter_store_key (sub { $store_key = $_ }) ;
- $db->filter_fetch_value (sub { $fetch_value = $_}) ;
- $db->filter_store_value (sub { $store_value = $_ }) ;
-
- $_ = "original" ;
-
- $h{"fred"} = "joe" ;
- # fk sk fv sv
- ok(checkOutput("", "fred", "", "joe"));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"fred"}, "joe");
- # fk sk fv sv
- ok(checkOutput("", "fred", "joe", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "fred");
- # fk sk fv sv
- ok(checkOutput("fred", "", "", ""));
-
- # replace the filters, but remember the previous set
- my ($old_fk) = $db->filter_fetch_key
- (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
- my ($old_sk) = $db->filter_store_key
- (sub { $_ = lc $_ ; $store_key = $_ }) ;
- my ($old_fv) = $db->filter_fetch_value
- (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
- my ($old_sv) = $db->filter_store_value
- (sub { s/o/x/g; $store_value = $_ }) ;
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- $h{"Fred"} = "Joe" ;
- # fk sk fv sv
- ok(checkOutput("", "fred", "", "Jxe"));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"Fred"}, "[Jxe]");
- # fk sk fv sv
- ok(checkOutput("", "fred", "[Jxe]", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "FRED");
- # fk sk fv sv
- ok(checkOutput("FRED", "", "", ""));
-
- # put the original filters back
- $db->filter_fetch_key ($old_fk);
- $db->filter_store_key ($old_sk);
- $db->filter_fetch_value ($old_fv);
- $db->filter_store_value ($old_sv);
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- $h{"fred"} = "joe" ;
- ok(checkOutput("", "fred", "", "joe"));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"fred"}, "joe");
- ok(checkOutput("", "fred", "joe", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "fred");
- ok(checkOutput("fred", "", "", ""));
-
- # delete the filters
- $db->filter_fetch_key (undef);
- $db->filter_store_key (undef);
- $db->filter_fetch_value (undef);
- $db->filter_store_value (undef);
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- $h{"fred"} = "joe" ;
- ok(checkOutput("", "", "", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"fred"}, "joe");
- ok(checkOutput("", "", "", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "fred");
- ok(checkOutput("", "", "", ""));
-
- undef $db ;
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # DBM Filter with a closure
-
- my (%h, $db) ;
-
- unlink <Op_dbmx*>;
- $db = tie %h, $DBM_Class, 'Op_dbmx', GDBM_WRCREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- my %result = () ;
-
- sub Closure
- {
- my ($name) = @_ ;
- my $count = 0 ;
- my @kept = () ;
-
- return sub { ++$count ;
- push @kept, $_ ;
- $result{$name} = "$name - $count: [@kept]" ;
- }
- }
-
- $db->filter_store_key(Closure("store key")) ;
- $db->filter_store_value(Closure("store value")) ;
- $db->filter_fetch_key(Closure("fetch key")) ;
- $db->filter_fetch_value(Closure("fetch value")) ;
-
- $_ = "original" ;
-
- $h{"fred"} = "joe" ;
- is($result{"store key"}, "store key - 1: [fred]");
- is($result{"store value"}, "store value - 1: [joe]");
- is($result{"fetch key"}, undef);
- is($result{"fetch value"}, undef);
- is($_, "original");
-
- is($db->FIRSTKEY(), "fred");
- is($result{"store key"}, "store key - 1: [fred]");
- is($result{"store value"}, "store value - 1: [joe]");
- is($result{"fetch key"}, "fetch key - 1: [fred]");
- is($result{"fetch value"}, undef);
- is($_, "original");
-
- $h{"jim"} = "john" ;
- is($result{"store key"}, "store key - 2: [fred jim]");
- is($result{"store value"}, "store value - 2: [joe john]");
- is($result{"fetch key"}, "fetch key - 1: [fred]");
- is($result{"fetch value"}, undef);
- is($_, "original");
-
- is($h{"fred"}, "joe");
- is($result{"store key"}, "store key - 3: [fred jim fred]");
- is($result{"store value"}, "store value - 2: [joe john]");
- is($result{"fetch key"}, "fetch key - 1: [fred]");
- is($result{"fetch value"}, "fetch value - 1: [joe]");
- is($_, "original");
-
- undef $db ;
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # DBM Filter recursion detection
- my (%h, $db) ;
- unlink <Op_dbmx*>;
-
- $db = tie %h, $DBM_Class, 'Op_dbmx', GDBM_WRCREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- $db->filter_store_key (sub { $_ = $h{$_} }) ;
-
- eval '$h{1} = 1234' ;
- like($@, qr/^recursion detected in filter_store_key at/);
-
- undef $db ;
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # Bug ID 20001013.009
- #
- # test that $hash{KEY} = undef doesn't produce the warning
- # Use of uninitialized value in null operation
-
- unlink <Op_dbmx*>;
- my %h ;
- my $a = "";
- local $SIG{__WARN__} = sub {$a = $_[0]} ;
-
- isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', GDBM_WRCREAT, 0640), $DBM_Class);
- $h{ABC} = undef;
- is($a, "");
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # When iterating over a tied hash using "each", the key passed to FETCH
- # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
- # key in FETCH via a filter_fetch_key method we need to check that the
- # modified key doesn't get passed to NEXTKEY.
- # Also Test "keys" & "values" while we are at it.
-
- unlink <Op_dbmx*>;
- my $bad_key = 0 ;
- my %h = () ;
- my $db = tie %h, $DBM_Class, 'Op_dbmx', GDBM_WRCREAT, 0640;
- isa_ok($db, $DBM_Class);
- $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
- $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
-
- $h{'Alpha_ABC'} = 2 ;
- $h{'Alpha_DEF'} = 5 ;
-
- is($h{'Alpha_ABC'}, 2);
- is($h{'Alpha_DEF'}, 5);
-
- my ($k, $v) = ("","");
- while (($k, $v) = each %h) {}
- is($bad_key, 0);
-
- $bad_key = 0 ;
- foreach $k (keys %h) {}
- is($bad_key, 0);
-
- $bad_key = 0 ;
- foreach $v (values %h) {}
- is($bad_key, 0);
-
- undef $db ;
- untie %h ;
- unlink <Op_dbmx*>;
-}
-
-{
- # Check that DBM Filter can cope with read-only $_
-
- my %h ;
- unlink <Op1_dbmx*>;
-
- my $db = tie %h, $DBM_Class, 'Op1_dbmx', GDBM_WRCREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- $db->filter_fetch_key (sub { }) ;
- $db->filter_store_key (sub { }) ;
- $db->filter_fetch_value (sub { }) ;
- $db->filter_store_value (sub { }) ;
-
- $_ = "original" ;
-
- $h{"fred"} = "joe" ;
- is($h{"fred"}, "joe");
-
- is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
- is($@, '');
-
-
- # delete the filters
- $db->filter_fetch_key (undef);
- $db->filter_store_key (undef);
- $db->filter_fetch_value (undef);
- $db->filter_store_value (undef);
-
- $h{"fred"} = "joe" ;
-
- is($h{"fred"}, "joe");
-
- is($db->FIRSTKEY(), "fred");
-
- is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
- is($@, '');
-
- undef $db ;
- untie %h;
- unlink <Op1_dbmx*>;
-}
+require '../../t/lib/dbmt_common.pl';
#!./perl
-# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+our $DBM_Class = 'NDBM_File';
-our $DBM_Class;
-
-BEGIN {
- $DBM_Class = 'NDBM_File';
-}
-
-BEGIN {
- require Config; import Config;
- if ($Config{'extensions'} !~ /\b$DBM_Class\b/) {
- print "1..0 # Skip: $DBM_Class was not built\n";
- exit 0;
- }
-}
-
-use strict;
-use warnings;
-
-use Test::More tests => 82;
-
-BEGIN {use_ok($DBM_Class)};
-#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
-use Fcntl;
-
-unlink <Op_dbmx.*>;
-
-umask(0);
-my %h ;
-isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640), $DBM_Class);
-
-my $Dfile = "Op_dbmx.pag";
-if (! -e $Dfile) {
- ($Dfile) = <Op_dbmx*>;
-}
-SKIP: {
- skip "different file permission semantics on $^O", 1
- if $^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin';
- my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
- $blksize,$blocks) = stat($Dfile);
- is($mode & 0777, 0640);
-}
-my $i = 0;
-while (my ($key,$value) = each(%h)) {
- $i++;
-}
-is($i, 0);
-
-$h{'goner1'} = 'snork';
-
-$h{'abc'} = 'ABC';
-$h{'def'} = 'DEF';
-$h{'jkl','mno'} = "JKL\034MNO";
-$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
-$h{'a'} = 'A';
-$h{'b'} = 'B';
-$h{'c'} = 'C';
-$h{'d'} = 'D';
-$h{'e'} = 'E';
-$h{'f'} = 'F';
-$h{'g'} = 'G';
-$h{'h'} = 'H';
-$h{'i'} = 'I';
-
-$h{'goner2'} = 'snork';
-delete $h{'goner2'};
-
-untie(%h);
-isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', O_RDWR, 0640), $DBM_Class);
-
-$h{'j'} = 'J';
-$h{'k'} = 'K';
-$h{'l'} = 'L';
-$h{'m'} = 'M';
-$h{'n'} = 'N';
-$h{'o'} = 'O';
-$h{'p'} = 'P';
-$h{'q'} = 'Q';
-$h{'r'} = 'R';
-$h{'s'} = 'S';
-$h{'t'} = 'T';
-$h{'u'} = 'U';
-$h{'v'} = 'V';
-$h{'w'} = 'W';
-$h{'x'} = 'X';
-$h{'y'} = 'Y';
-$h{'z'} = 'Z';
-
-$h{'goner3'} = 'snork';
-
-delete $h{'goner1'};
-delete $h{'goner3'};
-
-my @keys = keys(%h);
-my @values = values(%h);
-
-is($#keys, 29);
-is($#values, 29);
-
-while (my ($key,$value) = each(%h)) {
- if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
- $key =~ y/a-z/A-Z/;
- $i++ if $key eq $value;
- }
-}
-
-is($i, 30);
-
-@keys = ('blurfl', keys(%h), 'dyick');
-is($#keys, 31);
-
-$h{'foo'} = '';
-$h{''} = 'bar';
-
-my $ok = 1;
-for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
-for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
-is($ok, 1, 'check cache overflow and numeric keys and contents');
-
-my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
- $blksize,$blocks) = stat($Dfile);
-cmp_ok($size, '>', 0);
-
-@h{0..200} = 200..400;
-my @foo = @h{0..200};
-is(join(':',200..400), join(':',@foo));
-
-is($h{'foo'}, '');
-is($h{''}, 'bar');
-
-untie %h;
-unlink <Op_dbmx*>, $Dfile;
-
-{
- # sub-class test
-
- package Another ;
-
- open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
- printf FILE <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class;
-
- package SubDB ;
-
- use strict ;
- use warnings ;
- use vars qw(@ISA @EXPORT) ;
-
- require Exporter ;
- use %s;
- @ISA=qw(%s);
- @EXPORT = @%s::EXPORT ;
-
- sub STORE {
- my $self = shift ;
- my $key = shift ;
- my $value = shift ;
- $self->SUPER::STORE($key, $value * 2) ;
- }
-
- sub FETCH {
- my $self = shift ;
- my $key = shift ;
- $self->SUPER::FETCH($key) - 1 ;
- }
-
- sub A_new_method
- {
- my $self = shift ;
- my $key = shift ;
- my $value = $self->FETCH($key) ;
- return "[[$value]]" ;
- }
-
- 1 ;
-EOM
-
- close FILE or die "Could not close: $!";
-
- BEGIN { push @INC, '.'; }
- unlink <dbhash_tmp*> ;
-
- eval 'use SubDB ; use Fcntl ;';
- main::is($@, "");
- my %h ;
- my $X ;
- eval '
- $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 );
- ' ;
-
- main::is($@, "");
-
- my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
- main::is($@, "");
- main::is($ret, 5);
-
- $ret = eval '$X->A_new_method("fred") ' ;
- main::is($@, "");
- main::is($ret, "[[5]]");
-
- undef $X;
- untie(%h);
- unlink "SubDB.pm", <dbhash_tmp.*> ;
-
-}
-
-untie %h;
-unlink <Op_dbmx*>, $Dfile;
-
-{
- # DBM Filter tests
- my (%h, $db) ;
- my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
-
- sub checkOutput
- {
- my($fk, $sk, $fv, $sv) = @_ ;
- return
- $fetch_key eq $fk && $store_key eq $sk &&
- $fetch_value eq $fv && $store_value eq $sv &&
- $_ eq 'original' ;
- }
-
- unlink <Op_dbmx*>;
- $db = tie %h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
- $db->filter_store_key (sub { $store_key = $_ }) ;
- $db->filter_fetch_value (sub { $fetch_value = $_}) ;
- $db->filter_store_value (sub { $store_value = $_ }) ;
-
- $_ = "original" ;
-
- $h{"fred"} = "joe" ;
- # fk sk fv sv
- ok(checkOutput("", "fred", "", "joe"));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"fred"}, "joe");
- # fk sk fv sv
- ok(checkOutput("", "fred", "joe", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "fred");
- # fk sk fv sv
- ok(checkOutput("fred", "", "", ""));
-
- # replace the filters, but remember the previous set
- my ($old_fk) = $db->filter_fetch_key
- (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
- my ($old_sk) = $db->filter_store_key
- (sub { $_ = lc $_ ; $store_key = $_ }) ;
- my ($old_fv) = $db->filter_fetch_value
- (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
- my ($old_sv) = $db->filter_store_value
- (sub { s/o/x/g; $store_value = $_ }) ;
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- $h{"Fred"} = "Joe" ;
- # fk sk fv sv
- ok(checkOutput("", "fred", "", "Jxe"));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"Fred"}, "[Jxe]");
- # fk sk fv sv
- ok(checkOutput("", "fred", "[Jxe]", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "FRED");
- # fk sk fv sv
- ok(checkOutput("FRED", "", "", ""));
-
- # put the original filters back
- $db->filter_fetch_key ($old_fk);
- $db->filter_store_key ($old_sk);
- $db->filter_fetch_value ($old_fv);
- $db->filter_store_value ($old_sv);
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- $h{"fred"} = "joe" ;
- ok(checkOutput("", "fred", "", "joe"));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"fred"}, "joe");
- ok(checkOutput("", "fred", "joe", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "fred");
- ok(checkOutput("fred", "", "", ""));
-
- # delete the filters
- $db->filter_fetch_key (undef);
- $db->filter_store_key (undef);
- $db->filter_fetch_value (undef);
- $db->filter_store_value (undef);
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- $h{"fred"} = "joe" ;
- ok(checkOutput("", "", "", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"fred"}, "joe");
- ok(checkOutput("", "", "", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "fred");
- ok(checkOutput("", "", "", ""));
-
- undef $db ;
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # DBM Filter with a closure
-
- my (%h, $db) ;
-
- unlink <Op_dbmx*>;
- $db = tie %h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- my %result = () ;
-
- sub Closure
- {
- my ($name) = @_ ;
- my $count = 0 ;
- my @kept = () ;
-
- return sub { ++$count ;
- push @kept, $_ ;
- $result{$name} = "$name - $count: [@kept]" ;
- }
- }
-
- $db->filter_store_key(Closure("store key")) ;
- $db->filter_store_value(Closure("store value")) ;
- $db->filter_fetch_key(Closure("fetch key")) ;
- $db->filter_fetch_value(Closure("fetch value")) ;
-
- $_ = "original" ;
-
- $h{"fred"} = "joe" ;
- is($result{"store key"}, "store key - 1: [fred]");
- is($result{"store value"}, "store value - 1: [joe]");
- is($result{"fetch key"}, undef);
- is($result{"fetch value"}, undef);
- is($_, "original");
-
- is($db->FIRSTKEY(), "fred");
- is($result{"store key"}, "store key - 1: [fred]");
- is($result{"store value"}, "store value - 1: [joe]");
- is($result{"fetch key"}, "fetch key - 1: [fred]");
- is($result{"fetch value"}, undef);
- is($_, "original");
-
- $h{"jim"} = "john" ;
- is($result{"store key"}, "store key - 2: [fred jim]");
- is($result{"store value"}, "store value - 2: [joe john]");
- is($result{"fetch key"}, "fetch key - 1: [fred]");
- is($result{"fetch value"}, undef);
- is($_, "original");
-
- is($h{"fred"}, "joe");
- is($result{"store key"}, "store key - 3: [fred jim fred]");
- is($result{"store value"}, "store value - 2: [joe john]");
- is($result{"fetch key"}, "fetch key - 1: [fred]");
- is($result{"fetch value"}, "fetch value - 1: [joe]");
- is($_, "original");
-
- undef $db ;
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # DBM Filter recursion detection
- my (%h, $db) ;
- unlink <Op_dbmx*>;
-
- $db = tie %h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- $db->filter_store_key (sub { $_ = $h{$_} }) ;
-
- eval '$h{1} = 1234' ;
- like($@, qr/^recursion detected in filter_store_key at/);
-
- undef $db ;
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # Bug ID 20001013.009
- #
- # test that $hash{KEY} = undef doesn't produce the warning
- # Use of uninitialized value in null operation
-
- unlink <Op_dbmx*>;
- my %h ;
- my $a = "";
- local $SIG{__WARN__} = sub {$a = $_[0]} ;
-
- isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640), $DBM_Class);
- $h{ABC} = undef;
- is($a, "");
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # When iterating over a tied hash using "each", the key passed to FETCH
- # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
- # key in FETCH via a filter_fetch_key method we need to check that the
- # modified key doesn't get passed to NEXTKEY.
- # Also Test "keys" & "values" while we are at it.
-
- unlink <Op_dbmx*>;
- my $bad_key = 0 ;
- my %h = () ;
- my $db = tie %h, $DBM_Class,'Op_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
- $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
- $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
-
- $h{'Alpha_ABC'} = 2 ;
- $h{'Alpha_DEF'} = 5 ;
-
- is($h{'Alpha_ABC'}, 2);
- is($h{'Alpha_DEF'}, 5);
-
- my ($k, $v) = ("","");
- while (($k, $v) = each %h) {}
- is($bad_key, 0);
-
- $bad_key = 0 ;
- foreach $k (keys %h) {}
- is($bad_key, 0);
-
- $bad_key = 0 ;
- foreach $v (values %h) {}
- is($bad_key, 0);
-
- undef $db ;
- untie %h ;
- unlink <Op_dbmx*>;
-}
-
-{
- # Check that DBM Filter can cope with read-only $_
-
- my %h ;
- unlink <Op1_dbmx*>;
-
- my $db = tie %h, $DBM_Class, 'Op1_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- $db->filter_fetch_key (sub { }) ;
- $db->filter_store_key (sub { }) ;
- $db->filter_fetch_value (sub { }) ;
- $db->filter_store_value (sub { }) ;
-
- $_ = "original" ;
-
- $h{"fred"} = "joe" ;
- is($h{"fred"}, "joe");
-
- is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
- is($@, '');
-
-
- # delete the filters
- $db->filter_fetch_key (undef);
- $db->filter_store_key (undef);
- $db->filter_fetch_value (undef);
- $db->filter_store_value (undef);
-
- $h{"fred"} = "joe" ;
-
- is($h{"fred"}, "joe");
-
- is($db->FIRSTKEY(), "fred");
-
- is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
- is($@, '');
-
- undef $db ;
- untie %h;
- unlink <Op1_dbmx*>;
-}
+require '../../t/lib/dbmt_common.pl';
#!./perl
-# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+our $DBM_Class = 'ODBM_File';
-our $DBM_Class;
-
-BEGIN {
- $DBM_Class = 'ODBM_File';
-}
-
-BEGIN {
- require Config; import Config;
- if ($Config{'extensions'} !~ /\b$DBM_Class\b/ or $Config{'d_cplusplus'}) {
- print "1..0 # Skip: $DBM_Class was not built\n";
- exit 0;
- }
-}
-
-use strict;
-use warnings;
-
-use Test::More tests => 82;
-
-BEGIN {use_ok($DBM_Class)};
-#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
-use Fcntl;
-
-unlink <Op_dbmx.*>;
-
-umask(0);
-my %h ;
-isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640), $DBM_Class);
-
-my $Dfile = "Op_dbmx.pag";
-if (! -e $Dfile) {
- ($Dfile) = <Op_dbmx*>;
-}
-SKIP: {
- skip "different file permission semantics on $^O", 1
- if $^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin';
- my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
- $blksize,$blocks) = stat($Dfile);
- is($mode & 0777, 0640);
-}
-my $i = 0;
-while (my ($key,$value) = each(%h)) {
- $i++;
-}
-is($i, 0);
-
-$h{'goner1'} = 'snork';
-
-$h{'abc'} = 'ABC';
-$h{'def'} = 'DEF';
-$h{'jkl','mno'} = "JKL\034MNO";
-$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
-$h{'a'} = 'A';
-$h{'b'} = 'B';
-$h{'c'} = 'C';
-$h{'d'} = 'D';
-$h{'e'} = 'E';
-$h{'f'} = 'F';
-$h{'g'} = 'G';
-$h{'h'} = 'H';
-$h{'i'} = 'I';
-
-$h{'goner2'} = 'snork';
-delete $h{'goner2'};
-
-untie(%h);
-isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', O_RDWR, 0640), $DBM_Class);
-
-$h{'j'} = 'J';
-$h{'k'} = 'K';
-$h{'l'} = 'L';
-$h{'m'} = 'M';
-$h{'n'} = 'N';
-$h{'o'} = 'O';
-$h{'p'} = 'P';
-$h{'q'} = 'Q';
-$h{'r'} = 'R';
-$h{'s'} = 'S';
-$h{'t'} = 'T';
-$h{'u'} = 'U';
-$h{'v'} = 'V';
-$h{'w'} = 'W';
-$h{'x'} = 'X';
-$h{'y'} = 'Y';
-$h{'z'} = 'Z';
-
-$h{'goner3'} = 'snork';
-
-delete $h{'goner1'};
-delete $h{'goner3'};
-
-my @keys = keys(%h);
-my @values = values(%h);
-
-is($#keys, 29);
-is($#values, 29);
-
-while (my ($key,$value) = each(%h)) {
- if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
- $key =~ y/a-z/A-Z/;
- $i++ if $key eq $value;
- }
-}
-
-is($i, 30);
-
-@keys = ('blurfl', keys(%h), 'dyick');
-is($#keys, 31);
-
-$h{'foo'} = '';
-$h{''} = 'bar';
-
-my $ok = 1;
-for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
-for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
-is($ok, 1, 'check cache overflow and numeric keys and contents');
-
-my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
- $blksize,$blocks) = stat($Dfile);
-cmp_ok($size, '>', 0);
-
-@h{0..200} = 200..400;
-my @foo = @h{0..200};
-is(join(':',200..400), join(':',@foo));
-
-is($h{'foo'}, '');
-is($h{''}, 'bar');
-
-untie %h;
-unlink <Op_dbmx*>, $Dfile;
-
-{
- # sub-class test
-
- package Another ;
-
- open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
- printf FILE <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class;
-
- package SubDB ;
-
- use strict ;
- use warnings ;
- use vars qw(@ISA @EXPORT) ;
-
- require Exporter ;
- use %s;
- @ISA=qw(%s);
- @EXPORT = @%s::EXPORT ;
-
- sub STORE {
- my $self = shift ;
- my $key = shift ;
- my $value = shift ;
- $self->SUPER::STORE($key, $value * 2) ;
- }
-
- sub FETCH {
- my $self = shift ;
- my $key = shift ;
- $self->SUPER::FETCH($key) - 1 ;
- }
-
- sub A_new_method
- {
- my $self = shift ;
- my $key = shift ;
- my $value = $self->FETCH($key) ;
- return "[[$value]]" ;
- }
-
- 1 ;
-EOM
-
- close FILE or die "Could not close: $!";
-
- BEGIN { push @INC, '.'; }
- unlink <dbhash_tmp*> ;
-
- eval 'use SubDB ; use Fcntl ;';
- main::is($@, "");
- my %h ;
- my $X ;
- eval '
- $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 );
- ' ;
-
- main::is($@, "");
-
- my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
- main::is($@, "");
- main::is($ret, 5);
-
- $ret = eval '$X->A_new_method("fred") ' ;
- main::is($@, "");
- main::is($ret, "[[5]]");
-
- undef $X;
- untie(%h);
- unlink "SubDB.pm", <dbhash_tmp.*> ;
-
-}
-
-untie %h;
-unlink <Op_dbmx*>, $Dfile;
-
-{
- # DBM Filter tests
- my (%h, $db) ;
- my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
-
- sub checkOutput
- {
- my($fk, $sk, $fv, $sv) = @_ ;
- return
- $fetch_key eq $fk && $store_key eq $sk &&
- $fetch_value eq $fv && $store_value eq $sv &&
- $_ eq 'original' ;
- }
-
- unlink <Op_dbmx*>;
- $db = tie %h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
- $db->filter_store_key (sub { $store_key = $_ }) ;
- $db->filter_fetch_value (sub { $fetch_value = $_}) ;
- $db->filter_store_value (sub { $store_value = $_ }) ;
-
- $_ = "original" ;
-
- $h{"fred"} = "joe" ;
- # fk sk fv sv
- ok(checkOutput("", "fred", "", "joe"));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"fred"}, "joe");
- # fk sk fv sv
- ok(checkOutput("", "fred", "joe", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "fred");
- # fk sk fv sv
- ok(checkOutput("fred", "", "", ""));
-
- # replace the filters, but remember the previous set
- my ($old_fk) = $db->filter_fetch_key
- (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
- my ($old_sk) = $db->filter_store_key
- (sub { $_ = lc $_ ; $store_key = $_ }) ;
- my ($old_fv) = $db->filter_fetch_value
- (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
- my ($old_sv) = $db->filter_store_value
- (sub { s/o/x/g; $store_value = $_ }) ;
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- $h{"Fred"} = "Joe" ;
- # fk sk fv sv
- ok(checkOutput("", "fred", "", "Jxe"));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"Fred"}, "[Jxe]");
- # fk sk fv sv
- ok(checkOutput("", "fred", "[Jxe]", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "FRED");
- # fk sk fv sv
- ok(checkOutput("FRED", "", "", ""));
-
- # put the original filters back
- $db->filter_fetch_key ($old_fk);
- $db->filter_store_key ($old_sk);
- $db->filter_fetch_value ($old_fv);
- $db->filter_store_value ($old_sv);
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- $h{"fred"} = "joe" ;
- ok(checkOutput("", "fred", "", "joe"));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"fred"}, "joe");
- ok(checkOutput("", "fred", "joe", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "fred");
- ok(checkOutput("fred", "", "", ""));
-
- # delete the filters
- $db->filter_fetch_key (undef);
- $db->filter_store_key (undef);
- $db->filter_fetch_value (undef);
- $db->filter_store_value (undef);
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- $h{"fred"} = "joe" ;
- ok(checkOutput("", "", "", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"fred"}, "joe");
- ok(checkOutput("", "", "", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "fred");
- ok(checkOutput("", "", "", ""));
-
- undef $db ;
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # DBM Filter with a closure
-
- my (%h, $db) ;
-
- unlink <Op_dbmx*>;
- $db = tie %h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- my %result = () ;
-
- sub Closure
- {
- my ($name) = @_ ;
- my $count = 0 ;
- my @kept = () ;
-
- return sub { ++$count ;
- push @kept, $_ ;
- $result{$name} = "$name - $count: [@kept]" ;
- }
- }
-
- $db->filter_store_key(Closure("store key")) ;
- $db->filter_store_value(Closure("store value")) ;
- $db->filter_fetch_key(Closure("fetch key")) ;
- $db->filter_fetch_value(Closure("fetch value")) ;
-
- $_ = "original" ;
-
- $h{"fred"} = "joe" ;
- is($result{"store key"}, "store key - 1: [fred]");
- is($result{"store value"}, "store value - 1: [joe]");
- is($result{"fetch key"}, undef);
- is($result{"fetch value"}, undef);
- is($_, "original");
-
- is($db->FIRSTKEY(), "fred");
- is($result{"store key"}, "store key - 1: [fred]");
- is($result{"store value"}, "store value - 1: [joe]");
- is($result{"fetch key"}, "fetch key - 1: [fred]");
- is($result{"fetch value"}, undef);
- is($_, "original");
-
- $h{"jim"} = "john" ;
- is($result{"store key"}, "store key - 2: [fred jim]");
- is($result{"store value"}, "store value - 2: [joe john]");
- is($result{"fetch key"}, "fetch key - 1: [fred]");
- is($result{"fetch value"}, undef);
- is($_, "original");
-
- is($h{"fred"}, "joe");
- is($result{"store key"}, "store key - 3: [fred jim fred]");
- is($result{"store value"}, "store value - 2: [joe john]");
- is($result{"fetch key"}, "fetch key - 1: [fred]");
- is($result{"fetch value"}, "fetch value - 1: [joe]");
- is($_, "original");
-
- undef $db ;
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # DBM Filter recursion detection
- my (%h, $db) ;
- unlink <Op_dbmx*>;
-
- $db = tie %h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- $db->filter_store_key (sub { $_ = $h{$_} }) ;
-
- eval '$h{1} = 1234' ;
- like($@, qr/^recursion detected in filter_store_key at/);
-
- undef $db ;
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # Bug ID 20001013.009
- #
- # test that $hash{KEY} = undef doesn't produce the warning
- # Use of uninitialized value in null operation
-
- unlink <Op_dbmx*>;
- my %h ;
- my $a = "";
- local $SIG{__WARN__} = sub {$a = $_[0]} ;
-
- isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640), $DBM_Class);
- $h{ABC} = undef;
- is($a, "");
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # When iterating over a tied hash using "each", the key passed to FETCH
- # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
- # key in FETCH via a filter_fetch_key method we need to check that the
- # modified key doesn't get passed to NEXTKEY.
- # Also Test "keys" & "values" while we are at it.
-
- unlink <Op_dbmx*>;
- my $bad_key = 0 ;
- my %h = () ;
- my $db = tie %h, $DBM_Class,'Op_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
- $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
- $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
-
- $h{'Alpha_ABC'} = 2 ;
- $h{'Alpha_DEF'} = 5 ;
-
- is($h{'Alpha_ABC'}, 2);
- is($h{'Alpha_DEF'}, 5);
-
- my ($k, $v) = ("","");
- while (($k, $v) = each %h) {}
- is($bad_key, 0);
-
- $bad_key = 0 ;
- foreach $k (keys %h) {}
- is($bad_key, 0);
-
- $bad_key = 0 ;
- foreach $v (values %h) {}
- is($bad_key, 0);
-
- undef $db ;
- untie %h ;
- unlink <Op_dbmx*>;
-}
-
-{
- # Check that DBM Filter can cope with read-only $_
-
- my %h ;
- unlink <Op1_dbmx*>;
-
- my $db = tie %h, $DBM_Class, 'Op1_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- $db->filter_fetch_key (sub { }) ;
- $db->filter_store_key (sub { }) ;
- $db->filter_fetch_value (sub { }) ;
- $db->filter_store_value (sub { }) ;
-
- $_ = "original" ;
-
- $h{"fred"} = "joe" ;
- is($h{"fred"}, "joe");
-
- is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
- is($@, '');
-
-
- # delete the filters
- $db->filter_fetch_key (undef);
- $db->filter_store_key (undef);
- $db->filter_fetch_value (undef);
- $db->filter_store_value (undef);
-
- $h{"fred"} = "joe" ;
-
- is($h{"fred"}, "joe");
-
- is($db->FIRSTKEY(), "fred");
-
- is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
- is($@, '');
-
- undef $db ;
- untie %h;
- unlink <Op1_dbmx*>;
-}
+require '../../t/lib/dbmt_common.pl';
if ($^O eq 'hpux') {
print <<EOM;
#!./perl
-# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+our $DBM_Class = 'SDBM_File';
-our $DBM_Class;
-
-BEGIN {
- $DBM_Class = 'SDBM_File';
-}
-
-BEGIN {
- require Config; import Config;
- if ($Config{'extensions'} !~ /\b$DBM_Class\b/) {
- print "1..0 # Skip: $DBM_Class was not built\n";
- exit 0;
- }
-}
-
-use strict;
-use warnings;
-
-use Test::More tests => 84;
-
-BEGIN {use_ok($DBM_Class)};
-#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
-use Fcntl;
-
-unlink <Op_dbmx.*>;
-
-umask(0);
-my %h ;
-isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640), $DBM_Class);
-
-my $Dfile = "Op_dbmx.pag";
-if (! -e $Dfile) {
- ($Dfile) = <Op_dbmx*>;
-}
-SKIP: {
- skip "different file permission semantics on $^O", 1
- if $^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin';
- my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
- $blksize,$blocks) = stat($Dfile);
- is($mode & 0777, 0640);
-}
-my $i = 0;
-while (my ($key,$value) = each(%h)) {
- $i++;
-}
-is($i, 0);
-
-$h{'goner1'} = 'snork';
-
-$h{'abc'} = 'ABC';
-$h{'def'} = 'DEF';
-$h{'jkl','mno'} = "JKL\034MNO";
-$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
-$h{'a'} = 'A';
-$h{'b'} = 'B';
-$h{'c'} = 'C';
-$h{'d'} = 'D';
-$h{'e'} = 'E';
-$h{'f'} = 'F';
-$h{'g'} = 'G';
-$h{'h'} = 'H';
-$h{'i'} = 'I';
-
-$h{'goner2'} = 'snork';
-delete $h{'goner2'};
-
-untie(%h);
-isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', O_RDWR, 0640), $DBM_Class);
-
-$h{'j'} = 'J';
-$h{'k'} = 'K';
-$h{'l'} = 'L';
-$h{'m'} = 'M';
-$h{'n'} = 'N';
-$h{'o'} = 'O';
-$h{'p'} = 'P';
-$h{'q'} = 'Q';
-$h{'r'} = 'R';
-$h{'s'} = 'S';
-$h{'t'} = 'T';
-$h{'u'} = 'U';
-$h{'v'} = 'V';
-$h{'w'} = 'W';
-$h{'x'} = 'X';
-$h{'y'} = 'Y';
-$h{'z'} = 'Z';
-
-$h{'goner3'} = 'snork';
-
-delete $h{'goner1'};
-delete $h{'goner3'};
-
-my @keys = keys(%h);
-my @values = values(%h);
-
-is($#keys, 29);
-is($#values, 29);
-
-while (my ($key,$value) = each(%h)) {
- if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
- $key =~ y/a-z/A-Z/;
- $i++ if $key eq $value;
- }
-}
-
-is($i, 30);
-
-@keys = ('blurfl', keys(%h), 'dyick');
-is($#keys, 31);
-
-$h{'foo'} = '';
-$h{''} = 'bar';
-
-my $ok = 1;
-for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
-for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
-is($ok, 1, 'check cache overflow and numeric keys and contents');
-
-my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
- $blksize,$blocks) = stat($Dfile);
-cmp_ok($size, '>', 0);
-
-@h{0..200} = 200..400;
-my @foo = @h{0..200};
-is(join(':',200..400), join(':',@foo));
-
-is($h{'foo'}, '');
-is($h{''}, 'bar');
-
-is(exists $h{goner1}, '');
-is(exists $h{foo}, 1);
-
-untie %h;
-unlink <Op_dbmx*>, $Dfile;
-
-{
- # sub-class test
-
- package Another ;
-
- open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
- printf FILE <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class;
-
- package SubDB ;
-
- use strict ;
- use warnings ;
- use vars qw(@ISA @EXPORT) ;
-
- require Exporter ;
- use %s;
- @ISA=qw(%s);
- @EXPORT = @%s::EXPORT ;
-
- sub STORE {
- my $self = shift ;
- my $key = shift ;
- my $value = shift ;
- $self->SUPER::STORE($key, $value * 2) ;
- }
-
- sub FETCH {
- my $self = shift ;
- my $key = shift ;
- $self->SUPER::FETCH($key) - 1 ;
- }
-
- sub A_new_method
- {
- my $self = shift ;
- my $key = shift ;
- my $value = $self->FETCH($key) ;
- return "[[$value]]" ;
- }
-
- 1 ;
-EOM
-
- close FILE or die "Could not close: $!";
-
- BEGIN { push @INC, '.'; }
- unlink <dbhash_tmp*> ;
-
- eval 'use SubDB ; use Fcntl ;';
- main::is($@, "");
- my %h ;
- my $X ;
- eval '
- $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 );
- ' ;
-
- main::is($@, "");
-
- my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
- main::is($@, "");
- main::is($ret, 5);
-
- $ret = eval '$X->A_new_method("fred") ' ;
- main::is($@, "");
- main::is($ret, "[[5]]");
-
- undef $X;
- untie(%h);
- unlink "SubDB.pm", <dbhash_tmp.*> ;
-
-}
-
-untie %h;
-unlink <Op_dbmx*>, $Dfile;
-
-{
- # DBM Filter tests
- my (%h, $db) ;
- my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
-
- sub checkOutput
- {
- my($fk, $sk, $fv, $sv) = @_ ;
- return
- $fetch_key eq $fk && $store_key eq $sk &&
- $fetch_value eq $fv && $store_value eq $sv &&
- $_ eq 'original' ;
- }
-
- unlink <Op_dbmx*>;
- $db = tie %h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
- $db->filter_store_key (sub { $store_key = $_ }) ;
- $db->filter_fetch_value (sub { $fetch_value = $_}) ;
- $db->filter_store_value (sub { $store_value = $_ }) ;
-
- $_ = "original" ;
-
- $h{"fred"} = "joe" ;
- # fk sk fv sv
- ok(checkOutput("", "fred", "", "joe"));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"fred"}, "joe");
- # fk sk fv sv
- ok(checkOutput("", "fred", "joe", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "fred");
- # fk sk fv sv
- ok(checkOutput("fred", "", "", ""));
-
- # replace the filters, but remember the previous set
- my ($old_fk) = $db->filter_fetch_key
- (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
- my ($old_sk) = $db->filter_store_key
- (sub { $_ = lc $_ ; $store_key = $_ }) ;
- my ($old_fv) = $db->filter_fetch_value
- (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
- my ($old_sv) = $db->filter_store_value
- (sub { s/o/x/g; $store_value = $_ }) ;
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- $h{"Fred"} = "Joe" ;
- # fk sk fv sv
- ok(checkOutput("", "fred", "", "Jxe"));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"Fred"}, "[Jxe]");
- # fk sk fv sv
- ok(checkOutput("", "fred", "[Jxe]", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "FRED");
- # fk sk fv sv
- ok(checkOutput("FRED", "", "", ""));
-
- # put the original filters back
- $db->filter_fetch_key ($old_fk);
- $db->filter_store_key ($old_sk);
- $db->filter_fetch_value ($old_fv);
- $db->filter_store_value ($old_sv);
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- $h{"fred"} = "joe" ;
- ok(checkOutput("", "fred", "", "joe"));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"fred"}, "joe");
- ok(checkOutput("", "fred", "joe", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "fred");
- ok(checkOutput("fred", "", "", ""));
-
- # delete the filters
- $db->filter_fetch_key (undef);
- $db->filter_store_key (undef);
- $db->filter_fetch_value (undef);
- $db->filter_store_value (undef);
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- $h{"fred"} = "joe" ;
- ok(checkOutput("", "", "", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($h{"fred"}, "joe");
- ok(checkOutput("", "", "", ""));
-
- ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
- is($db->FIRSTKEY(), "fred");
- ok(checkOutput("", "", "", ""));
-
- undef $db ;
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # DBM Filter with a closure
-
- my (%h, $db) ;
-
- unlink <Op_dbmx*>;
- $db = tie %h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- my %result = () ;
-
- sub Closure
- {
- my ($name) = @_ ;
- my $count = 0 ;
- my @kept = () ;
-
- return sub { ++$count ;
- push @kept, $_ ;
- $result{$name} = "$name - $count: [@kept]" ;
- }
- }
-
- $db->filter_store_key(Closure("store key")) ;
- $db->filter_store_value(Closure("store value")) ;
- $db->filter_fetch_key(Closure("fetch key")) ;
- $db->filter_fetch_value(Closure("fetch value")) ;
-
- $_ = "original" ;
-
- $h{"fred"} = "joe" ;
- is($result{"store key"}, "store key - 1: [fred]");
- is($result{"store value"}, "store value - 1: [joe]");
- is($result{"fetch key"}, undef);
- is($result{"fetch value"}, undef);
- is($_, "original");
-
- is($db->FIRSTKEY(), "fred");
- is($result{"store key"}, "store key - 1: [fred]");
- is($result{"store value"}, "store value - 1: [joe]");
- is($result{"fetch key"}, "fetch key - 1: [fred]");
- is($result{"fetch value"}, undef);
- is($_, "original");
-
- $h{"jim"} = "john" ;
- is($result{"store key"}, "store key - 2: [fred jim]");
- is($result{"store value"}, "store value - 2: [joe john]");
- is($result{"fetch key"}, "fetch key - 1: [fred]");
- is($result{"fetch value"}, undef);
- is($_, "original");
-
- is($h{"fred"}, "joe");
- is($result{"store key"}, "store key - 3: [fred jim fred]");
- is($result{"store value"}, "store value - 2: [joe john]");
- is($result{"fetch key"}, "fetch key - 1: [fred]");
- is($result{"fetch value"}, "fetch value - 1: [joe]");
- is($_, "original");
-
- undef $db ;
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # DBM Filter recursion detection
- my (%h, $db) ;
- unlink <Op_dbmx*>;
-
- $db = tie %h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- $db->filter_store_key (sub { $_ = $h{$_} }) ;
-
- eval '$h{1} = 1234' ;
- like($@, qr/^recursion detected in filter_store_key at/);
-
- undef $db ;
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # Bug ID 20001013.009
- #
- # test that $hash{KEY} = undef doesn't produce the warning
- # Use of uninitialized value in null operation
-
- unlink <Op_dbmx*>;
- my %h ;
- my $a = "";
- local $SIG{__WARN__} = sub {$a = $_[0]} ;
-
- isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640), $DBM_Class);
- $h{ABC} = undef;
- is($a, "");
- untie %h;
- unlink <Op_dbmx*>;
-}
-
-{
- # When iterating over a tied hash using "each", the key passed to FETCH
- # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
- # key in FETCH via a filter_fetch_key method we need to check that the
- # modified key doesn't get passed to NEXTKEY.
- # Also Test "keys" & "values" while we are at it.
-
- unlink <Op_dbmx*>;
- my $bad_key = 0 ;
- my %h = () ;
- my $db = tie %h, $DBM_Class,'Op_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
- $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
- $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
-
- $h{'Alpha_ABC'} = 2 ;
- $h{'Alpha_DEF'} = 5 ;
-
- is($h{'Alpha_ABC'}, 2);
- is($h{'Alpha_DEF'}, 5);
-
- my ($k, $v) = ("","");
- while (($k, $v) = each %h) {}
- is($bad_key, 0);
-
- $bad_key = 0 ;
- foreach $k (keys %h) {}
- is($bad_key, 0);
-
- $bad_key = 0 ;
- foreach $v (values %h) {}
- is($bad_key, 0);
-
- undef $db ;
- untie %h ;
- unlink <Op_dbmx*>;
-}
-
-{
- # Check that DBM Filter can cope with read-only $_
-
- my %h ;
- unlink <Op1_dbmx*>;
-
- my $db = tie %h, $DBM_Class, 'Op1_dbmx', O_RDWR|O_CREAT, 0640;
- isa_ok($db, $DBM_Class);
-
- $db->filter_fetch_key (sub { }) ;
- $db->filter_store_key (sub { }) ;
- $db->filter_fetch_value (sub { }) ;
- $db->filter_store_value (sub { }) ;
-
- $_ = "original" ;
-
- $h{"fred"} = "joe" ;
- is($h{"fred"}, "joe");
-
- is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
- is($@, '');
-
-
- # delete the filters
- $db->filter_fetch_key (undef);
- $db->filter_store_key (undef);
- $db->filter_fetch_value (undef);
- $db->filter_store_value (undef);
-
- $h{"fred"} = "joe" ;
-
- is($h{"fred"}, "joe");
-
- is($db->FIRSTKEY(), "fred");
-
- is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
- is($@, '');
-
- undef $db ;
- untie %h;
- unlink <Op1_dbmx*>;
-}
+require '../../t/lib/dbmt_common.pl';
--- /dev/null
+#!perl
+BEGIN {
+}
+
+use strict;
+use warnings;
+
+use Test::More;
+use Config;
+
+our $DBM_Class;
+
+my ($create, $write);
+BEGIN {
+ plan(skip_all => "$DBM_Class was not built")
+ unless $Config{extensions} =~ /\b$DBM_Class\b/;
+ plan(skip_all => "$DBM_Class not compatible with C++")
+ if $DBM_Class eq 'ODBM_File' && $Config{d_cplusplus};
+
+ use_ok($DBM_Class);
+
+ if ($::Create_and_Write) {
+ ($create, $write) = eval $::Create_and_Write;
+ isnt($create, undef, "(eval q{$::Create_and_Write})[0]");
+ isnt($write, undef, "(eval q{$::Create_and_Write})[1]");
+ } else {
+ #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
+ use_ok('Fcntl');
+ $create = O_RDWR()|O_CREAT();
+ $write = O_RDWR();
+ }
+}
+
+unlink <Op_dbmx.*>;
+
+umask(0);
+my %h;
+isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class);
+
+my $Dfile = "Op_dbmx.pag";
+if (! -e $Dfile) {
+ ($Dfile) = <Op_dbmx*>;
+}
+SKIP: {
+ skip "different file permission semantics on $^O", 1
+ if $^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin';
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ is($mode & 0777, 0640);
+}
+my $i = 0;
+while (my ($key,$value) = each(%h)) {
+ $i++;
+}
+is($i, 0);
+
+$h{'goner1'} = 'snork';
+
+$h{'abc'} = 'ABC';
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+$h{'b'} = 'B';
+$h{'c'} = 'C';
+$h{'d'} = 'D';
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'G';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+
+$h{'goner2'} = 'snork';
+delete $h{'goner2'};
+
+untie(%h);
+isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $write, 0640), $DBM_Class);
+
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+$h{'goner3'} = 'snork';
+
+delete $h{'goner1'};
+delete $h{'goner3'};
+
+my @keys = keys(%h);
+my @values = values(%h);
+
+is($#keys, 29);
+is($#values, 29);
+
+while (my ($key, $value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+}
+
+is($i, 30);
+
+@keys = ('blurfl', keys(%h), 'dyick');
+is($#keys, 31);
+
+$h{'foo'} = '';
+$h{''} = 'bar';
+
+my $ok = 1;
+for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+is($ok, 1, 'check cache overflow and numeric keys and contents');
+
+my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+cmp_ok($size, '>', 0);
+
+@h{0..200} = 200..400;
+my @foo = @h{0..200};
+is(join(':',200..400), join(':',@foo));
+
+is($h{'foo'}, '');
+is($h{''}, 'bar');
+
+if($DBM_Class eq 'SDBM_File') {
+ is(exists $h{goner1}, '');
+ is(exists $h{foo}, 1);
+}
+
+untie %h;
+unlink <Op_dbmx*>, $Dfile;
+
+{
+ # sub-class test
+
+ package Another;
+
+ open my $file, '>', 'SubDB.pm' or die "Cannot open SubDB.pm: $!\n";
+ printf $file <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class;
+
+ package SubDB;
+
+ use strict;
+ use warnings;
+ use vars qw(@ISA @EXPORT);
+
+ require Exporter;
+ use %s;
+ @ISA=qw(%s);
+ @EXPORT = @%s::EXPORT;
+
+ sub STORE {
+ my $self = shift;
+ my $key = shift;
+ my $value = shift;
+ $self->SUPER::STORE($key, $value * 2);
+ }
+
+ sub FETCH {
+ my $self = shift;
+ my $key = shift;
+ $self->SUPER::FETCH($key) - 1;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift;
+ my $key = shift;
+ my $value = $self->FETCH($key);
+ return "[[$value]]";
+ }
+
+ 1;
+EOM
+
+ close $file or die "Could not close: $!";
+
+ BEGIN { push @INC, '.'; }
+ unlink <dbhash_tmp*>;
+
+ main::use_ok('SubDB');
+ my %h;
+ my $X;
+ eval '
+ $X = tie(%h, "SubDB", "dbhash_tmp", $create, 0640 );
+ ';
+
+ main::is($@, "");
+
+ my $ret = eval '$h{"fred"} = 3; return $h{"fred"} ';
+ main::is($@, "");
+ main::is($ret, 5);
+
+ $ret = eval '$X->A_new_method("fred") ';
+ main::is($@, "");
+ main::is($ret, "[[5]]");
+
+ if ($DBM_Class eq 'GDBM_File') {
+ $ret = eval 'GDBM_WRCREAT eq main::GDBM_WRCREAT';
+ main::is($@, "");
+ main::is($ret, 1);
+ }
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", <dbhash_tmp.*>;
+
+}
+
+untie %h;
+unlink <Op_dbmx*>, $Dfile;
+
+{
+ # DBM Filter tests
+ my (%h, $db);
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original';
+ }
+
+ unlink <Op_dbmx*>;
+ $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
+ isa_ok($db, $DBM_Class);
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ });
+ $db->filter_store_key (sub { $store_key = $_ });
+ $db->filter_fetch_value (sub { $fetch_value = $_});
+ $db->filter_store_value (sub { $store_value = $_ });
+
+ $_ = "original";
+
+ $h{"fred"} = "joe";
+ # fk sk fv sv
+ ok(checkOutput("", "fred", "", "joe"));
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
+ is($h{"fred"}, "joe");
+ # fk sk fv sv
+ ok(checkOutput("", "fred", "joe", ""));
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
+ is($db->FIRSTKEY(), "fred");
+ # fk sk fv sv
+ ok(checkOutput("fred", "", "", ""));
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_; $fetch_key = $_ });
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_; $store_key = $_ });
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ });
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ });
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
+ $h{"Fred"} = "Joe";
+ # fk sk fv sv
+ ok(checkOutput("", "fred", "", "Jxe"));
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
+ is($h{"Fred"}, "[Jxe]");
+ # fk sk fv sv
+ ok(checkOutput("", "fred", "[Jxe]", ""));
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
+ is($db->FIRSTKEY(), "FRED");
+ # fk sk fv sv
+ ok(checkOutput("FRED", "", "", ""));
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
+ $h{"fred"} = "joe";
+ ok(checkOutput("", "fred", "", "joe"));
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
+ is($h{"fred"}, "joe");
+ ok(checkOutput("", "fred", "joe", ""));
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
+ is($db->FIRSTKEY(), "fred");
+ ok(checkOutput("fred", "", "", ""));
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
+ $h{"fred"} = "joe";
+ ok(checkOutput("", "", "", ""));
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
+ is($h{"fred"}, "joe");
+ ok(checkOutput("", "", "", ""));
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4;
+ is($db->FIRSTKEY(), "fred");
+ ok(checkOutput("", "", "", ""));
+
+ undef $db;
+ untie %h;
+ unlink <Op_dbmx*>;
+}
+
+{
+ # DBM Filter with a closure
+
+ my (%h, $db);
+
+ unlink <Op_dbmx*>;
+ $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
+ isa_ok($db, $DBM_Class);
+
+ my %result = ();
+
+ sub Closure
+ {
+ my ($name) = @_;
+ my $count = 0;
+ my @kept = ();
+
+ return sub { ++$count;
+ push @kept, $_;
+ $result{$name} = "$name - $count: [@kept]";
+ }
+ }
+
+ $db->filter_store_key(Closure("store key"));
+ $db->filter_store_value(Closure("store value"));
+ $db->filter_fetch_key(Closure("fetch key"));
+ $db->filter_fetch_value(Closure("fetch value"));
+
+ $_ = "original";
+
+ $h{"fred"} = "joe";
+ is($result{"store key"}, "store key - 1: [fred]");
+ is($result{"store value"}, "store value - 1: [joe]");
+ is($result{"fetch key"}, undef);
+ is($result{"fetch value"}, undef);
+ is($_, "original");
+
+ is($db->FIRSTKEY(), "fred");
+ is($result{"store key"}, "store key - 1: [fred]");
+ is($result{"store value"}, "store value - 1: [joe]");
+ is($result{"fetch key"}, "fetch key - 1: [fred]");
+ is($result{"fetch value"}, undef);
+ is($_, "original");
+
+ $h{"jim"} = "john";
+ is($result{"store key"}, "store key - 2: [fred jim]");
+ is($result{"store value"}, "store value - 2: [joe john]");
+ is($result{"fetch key"}, "fetch key - 1: [fred]");
+ is($result{"fetch value"}, undef);
+ is($_, "original");
+
+ is($h{"fred"}, "joe");
+ is($result{"store key"}, "store key - 3: [fred jim fred]");
+ is($result{"store value"}, "store value - 2: [joe john]");
+ is($result{"fetch key"}, "fetch key - 1: [fred]");
+ is($result{"fetch value"}, "fetch value - 1: [joe]");
+ is($_, "original");
+
+ undef $db;
+ untie %h;
+ unlink <Op_dbmx*>;
+}
+
+{
+ # DBM Filter recursion detection
+ my (%h, $db);
+ unlink <Op_dbmx*>;
+
+ $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
+ isa_ok($db, $DBM_Class);
+
+ $db->filter_store_key (sub { $_ = $h{$_} });
+
+ eval '$h{1} = 1234';
+ like($@, qr/^recursion detected in filter_store_key at/);
+
+ undef $db;
+ untie %h;
+ unlink <Op_dbmx*>;
+}
+
+{
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+
+ unlink <Op_dbmx*>;
+ my %h;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]};
+
+ isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class);
+ $h{ABC} = undef;
+ is($a, "");
+ untie %h;
+ unlink <Op_dbmx*>;
+}
+
+{
+ # When iterating over a tied hash using "each", the key passed to FETCH
+ # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
+ # key in FETCH via a filter_fetch_key method we need to check that the
+ # modified key doesn't get passed to NEXTKEY.
+ # Also Test "keys" & "values" while we are at it.
+
+ unlink <Op_dbmx*>;
+ my $bad_key = 0;
+ my %h = ();
+ my $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640;
+ isa_ok($db, $DBM_Class);
+ $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_});
+ $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/; $_ =~ s/^Alpha_/Beta_/});
+
+ $h{'Alpha_ABC'} = 2;
+ $h{'Alpha_DEF'} = 5;
+
+ is($h{'Alpha_ABC'}, 2);
+ is($h{'Alpha_DEF'}, 5);
+
+ my ($k, $v) = ("", "");
+ while (($k, $v) = each %h) {}
+ is($bad_key, 0);
+
+ $bad_key = 0;
+ foreach $k (keys %h) {}
+ is($bad_key, 0);
+
+ $bad_key = 0;
+ foreach $v (values %h) {}
+ is($bad_key, 0);
+
+ undef $db;
+ untie %h;
+ unlink <Op_dbmx*>;
+}
+
+{
+ # Check that DBM Filter can cope with read-only $_
+
+ my %h;
+ unlink <Op1_dbmx*>;
+
+ my $db = tie %h, $DBM_Class, 'Op1_dbmx', $create, 0640;
+ isa_ok($db, $DBM_Class);
+
+ $db->filter_fetch_key (sub { });
+ $db->filter_store_key (sub { });
+ $db->filter_fetch_value (sub { });
+ $db->filter_store_value (sub { });
+
+ $_ = "original";
+
+ $h{"fred"} = "joe";
+ is($h{"fred"}, "joe");
+
+ is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
+ is($@, '');
+
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ $h{"fred"} = "joe";
+
+ is($h{"fred"}, "joe");
+
+ is($db->FIRSTKEY(), "fred");
+
+ is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
+ is($@, '');
+
+ undef $db;
+ untie %h;
+ unlink <Op1_dbmx*>;
+}
+
+done_testing();
+1;
projects / platform / upstream / perl.git / commitdiff