1#!./perl -w 2 3# ID: %I%, %G% 4 5use strict ; 6 7use lib 't' ; 8use BerkeleyDB; 9use util ; 10use Test::More; 11 12plan tests => 52; 13 14my $Dfile = "dbhash.tmp"; 15unlink $Dfile; 16 17umask(0) ; 18 19 20{ 21 # DBM Filter tests 22 use strict ; 23 my (%h, $db) ; 24 my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 25 unlink $Dfile; 26 27 sub checkOutput 28 { 29 my($fk, $sk, $fv, $sv) = @_ ; 30 return 31 $fetch_key eq $fk && $store_key eq $sk && 32 $fetch_value eq $fv && $store_value eq $sv && 33 $_ eq 'original' ; 34 } 35 36 ok $db = tie %h, 'BerkeleyDB::Hash', 37 -Filename => $Dfile, 38 -Flags => DB_CREATE; 39 40 $db->filter_fetch_key (sub { $fetch_key = $_ }) ; 41 $db->filter_store_key (sub { $store_key = $_ }) ; 42 $db->filter_fetch_value (sub { $fetch_value = $_}) ; 43 $db->filter_store_value (sub { $store_value = $_ }) ; 44 45 $_ = "original" ; 46 47 $h{"fred"} = "joe" ; 48 # fk sk fv sv 49 ok checkOutput( "", "fred", "", "joe") ; 50 51 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 52 ok $h{"fred"} eq "joe"; 53 # fk sk fv sv 54 ok checkOutput( "", "fred", "joe", "") ; 55 56 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 57 ok $db->FIRSTKEY() eq "fred" ; 58 # fk sk fv sv 59 ok checkOutput( "fred", "", "", "") ; 60 61 # replace the filters, but remember the previous set 62 my ($old_fk) = $db->filter_fetch_key 63 (sub { $_ = uc $_ ; $fetch_key = $_ }) ; 64 my ($old_sk) = $db->filter_store_key 65 (sub { $_ = lc $_ ; $store_key = $_ }) ; 66 my ($old_fv) = $db->filter_fetch_value 67 (sub { $_ = "[$_]"; $fetch_value = $_ }) ; 68 my ($old_sv) = $db->filter_store_value 69 (sub { s/o/x/g; $store_value = $_ }) ; 70 71 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 72 $h{"Fred"} = "Joe" ; 73 # fk sk fv sv 74 ok checkOutput( "", "fred", "", "Jxe") ; 75 76 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 77 ok $h{"Fred"} eq "[Jxe]"; 78 print "$h{'Fred'}\n"; 79 # fk sk fv sv 80 ok checkOutput( "", "fred", "[Jxe]", "") ; 81 82 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 83 ok $db->FIRSTKEY() eq "FRED" ; 84 # fk sk fv sv 85 ok checkOutput( "FRED", "", "", "") ; 86 87 # put the original filters back 88 $db->filter_fetch_key ($old_fk); 89 $db->filter_store_key ($old_sk); 90 $db->filter_fetch_value ($old_fv); 91 $db->filter_store_value ($old_sv); 92 93 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 94 $h{"fred"} = "joe" ; 95 ok checkOutput( "", "fred", "", "joe") ; 96 97 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 98 ok $h{"fred"} eq "joe"; 99 ok checkOutput( "", "fred", "joe", "") ; 100 101 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 102 ok $db->FIRSTKEY() eq "fred" ; 103 ok checkOutput( "fred", "", "", "") ; 104 105 # delete the filters 106 $db->filter_fetch_key (undef); 107 $db->filter_store_key (undef); 108 $db->filter_fetch_value (undef); 109 $db->filter_store_value (undef); 110 111 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 112 $h{"fred"} = "joe" ; 113 ok checkOutput( "", "", "", "") ; 114 115 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 116 ok $h{"fred"} eq "joe"; 117 ok checkOutput( "", "", "", "") ; 118 119 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 120 ok $db->FIRSTKEY() eq "fred" ; 121 ok checkOutput( "", "", "", "") ; 122 123 undef $db ; 124 untie %h; 125 unlink $Dfile; 126} 127 128{ 129 # DBM Filter with a closure 130 131 use strict ; 132 my (%h, $db) ; 133 134 unlink $Dfile; 135 ok $db = tie %h, 'BerkeleyDB::Hash', 136 -Filename => $Dfile, 137 -Flags => DB_CREATE; 138 139 my %result = () ; 140 141 sub Closure 142 { 143 my ($name) = @_ ; 144 my $count = 0 ; 145 my @kept = () ; 146 147 return sub { ++$count ; 148 push @kept, $_ ; 149 $result{$name} = "$name - $count: [@kept]" ; 150 } 151 } 152 153 $db->filter_store_key(Closure("store key")) ; 154 $db->filter_store_value(Closure("store value")) ; 155 $db->filter_fetch_key(Closure("fetch key")) ; 156 $db->filter_fetch_value(Closure("fetch value")) ; 157 158 $_ = "original" ; 159 160 $h{"fred"} = "joe" ; 161 ok $result{"store key"} eq "store key - 1: [fred]" ; 162 ok $result{"store value"} eq "store value - 1: [joe]" ; 163 ok ! defined $result{"fetch key"} ; 164 ok ! defined $result{"fetch value"} ; 165 ok $_ eq "original" ; 166 167 ok $db->FIRSTKEY() eq "fred" ; 168 ok $result{"store key"} eq "store key - 1: [fred]" ; 169 ok $result{"store value"} eq "store value - 1: [joe]" ; 170 ok $result{"fetch key"} eq "fetch key - 1: [fred]" ; 171 ok ! defined $result{"fetch value"} ; 172 ok $_ eq "original" ; 173 174 $h{"jim"} = "john" ; 175 ok $result{"store key"} eq "store key - 2: [fred jim]" ; 176 ok $result{"store value"} eq "store value - 2: [joe john]" ; 177 ok $result{"fetch key"} eq "fetch key - 1: [fred]" ; 178 ok ! defined $result{"fetch value"} ; 179 ok $_ eq "original" ; 180 181 ok $h{"fred"} eq "joe" ; 182 ok $result{"store key"} eq "store key - 3: [fred jim fred]" ; 183 ok $result{"store value"} eq "store value - 2: [joe john]" ; 184 ok $result{"fetch key"} eq "fetch key - 1: [fred]" ; 185 ok $result{"fetch value"} eq "fetch value - 1: [joe]" ; 186 ok $_ eq "original" ; 187 188 undef $db ; 189 untie %h; 190 unlink $Dfile; 191} 192 193{ 194 # DBM Filter recursion detection 195 use strict ; 196 my (%h, $db) ; 197 unlink $Dfile; 198 199 ok $db = tie %h, 'BerkeleyDB::Hash', 200 -Filename => $Dfile, 201 -Flags => DB_CREATE; 202 203 $db->filter_store_key (sub { $_ = $h{$_} }) ; 204 205 eval '$h{1} = 1234' ; 206 ok $@ =~ /^recursion detected in filter_store_key at/ ; 207 208 undef $db ; 209 untie %h; 210 unlink $Dfile; 211} 212 213{ 214 # Check that DBM Filter can cope with read-only $_ 215 216 #use warnings ; 217 use strict ; 218 my (%h, $db) ; 219 unlink $Dfile; 220 221 ok $db = tie %h, 'BerkeleyDB::Hash', 222 -Filename => $Dfile, 223 -Flags => DB_CREATE; 224 225 $db->filter_fetch_key (sub { }) ; 226 $db->filter_store_key (sub { }) ; 227 $db->filter_fetch_value (sub { }) ; 228 $db->filter_store_value (sub { }) ; 229 230 $_ = "original" ; 231 232 $h{"fred"} = "joe" ; 233 ok($h{"fred"} eq "joe"); 234 235 eval { grep { $h{$_} } (1, 2, 3) }; 236 ok (! $@); 237 238 239 # delete the filters 240 $db->filter_fetch_key (undef); 241 $db->filter_store_key (undef); 242 $db->filter_fetch_value (undef); 243 $db->filter_store_value (undef); 244 245 $h{"fred"} = "joe" ; 246 247 ok($h{"fred"} eq "joe"); 248 249 ok($db->FIRSTKEY() eq "fred") ; 250 251 eval { grep { $h{$_} } (1, 2, 3) }; 252 ok (! $@); 253 254 undef $db ; 255 untie %h; 256 unlink $Dfile; 257} 258 259if(0) 260{ 261 # Filter without tie 262 use strict ; 263 my (%h, $db) ; 264 265 unlink $Dfile; 266 ok $db = tie %h, 'BerkeleyDB::Hash', 267 -Filename => $Dfile, 268 -Flags => DB_CREATE; 269 270 my %result = () ; 271 272 sub INC { return ++ $_[0] } 273 sub DEC { return -- $_[0] } 274 #$db->filter_fetch_key (sub { warn "FFK $_\n"; $_ = INC($_); warn "XX\n" }) ; 275 #$db->filter_store_key (sub { warn "FSK $_\n"; $_ = DEC($_); warn "XX\n" }) ; 276 #$db->filter_fetch_value (sub { warn "FFV $_\n"; $_ = INC($_); warn "XX\n"}) ; 277 #$db->filter_store_value (sub { warn "FSV $_\n"; $_ = DEC($_); warn "XX\n" }) ; 278 279 $db->filter_fetch_key (sub { warn "FFK $_\n"; $_ = pack("i", $_); warn "XX\n" }) ; 280 $db->filter_store_key (sub { warn "FSK $_\n"; $_ = unpack("i", $_); warn "XX\n" }) ; 281 $db->filter_fetch_value (sub { warn "FFV $_\n"; $_ = pack("i", $_); warn "XX\n"}) ; 282 #$db->filter_store_value (sub { warn "FSV $_\n"; $_ = unpack("i", $_); warn "XX\n" }) ; 283 284 #$db->filter_fetch_key (sub { ++ $_ }) ; 285 #$db->filter_store_key (sub { -- $_ }) ; 286 #$db->filter_fetch_value (sub { ++ $_ }) ; 287 #$db->filter_store_value (sub { -- $_ }) ; 288 289 my ($k, $v) = (0,0); 290 ok ! $db->db_put(3,5); 291 exit; 292 ok ! $db->db_get(3, $v); 293 ok $v == 5 ; 294 295 $h{4} = 7 ; 296 ok $h{4} == 7; 297 298 $k = 10; 299 $v = 30; 300 $h{$k} = $v ; 301 ok $k == 10; 302 ok $v == 30; 303 ok $h{$k} == 30; 304 305 $k = 3; 306 ok ! $db->db_get($k, $v, DB_GET_BOTH); 307 ok $k == 3 ; 308 ok $v == 5 ; 309 310 my $cursor = $db->db_cursor(); 311 312 my %tmp = (); 313 while ($cursor->c_get($k, $v, DB_NEXT) == 0) 314 { 315 $tmp{$k} = $v; 316 } 317 318 ok keys %tmp == 3 ; 319 ok $tmp{3} == 5; 320 321 undef $cursor ; 322 undef $db ; 323 untie %h; 324 unlink $Dfile; 325} 326 327