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