diff options
Diffstat (limited to 't/lib/db-hash.t')
| -rwxr-xr-x | t/lib/db-hash.t | 191 |
1 files changed, 189 insertions, 2 deletions
diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t index 9f2456f7bb..21f2aadada 100755 --- a/t/lib/db-hash.t +++ b/t/lib/db-hash.t @@ -12,7 +12,7 @@ BEGIN { use DB_File; use Fcntl; -print "1..62\n"; +print "1..108\n"; sub ok { @@ -23,7 +23,7 @@ sub ok print "ok $no\n" ; } -$Dfile = "dbhash.tmp"; +my $Dfile = "dbhash.tmp"; unlink $Dfile; umask(0); @@ -413,4 +413,191 @@ EOM unlink "SubDB.pm", "dbhash.tmp" ; } + +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + 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' ; + } + + ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $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(64, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(65, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(66, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(67, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(68, 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(69, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(70, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(71, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(72, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(73, 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(74, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(75, $h{"fred"} eq "joe"); + ok(76, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(77, $db->FIRSTKEY() eq "fred") ; + ok(78, 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(79, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(80, $h{"fred"} eq "joe"); + ok(81, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(82, $db->FIRSTKEY() eq "fred") ; + ok(83, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + 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" ; + ok(85, $result{"store key"} eq "store key - 1: [fred]"); + ok(86, $result{"store value"} eq "store value - 1: [joe]"); + ok(87, ! defined $result{"fetch key"} ); + ok(88, ! defined $result{"fetch value"} ); + ok(89, $_ eq "original") ; + + ok(90, $db->FIRSTKEY() eq "fred") ; + ok(91, $result{"store key"} eq "store key - 1: [fred]"); + ok(92, $result{"store value"} eq "store value - 1: [joe]"); + ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(94, ! defined $result{"fetch value"} ); + ok(95, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(96, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(97, $result{"store value"} eq "store value - 2: [joe john]"); + ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(99, ! defined $result{"fetch value"} ); + ok(100, $_ eq "original") ; + + ok(101, $h{"fred"} eq "joe"); + ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(103, $result{"store value"} eq "store value - 2: [joe john]"); + ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(106, $_ eq "original") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(108, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink $Dfile; +} + exit ; |