1#!./perl 2 3# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ 4 5BEGIN { 6 require Config; import Config; 7 if ($Config{'extensions'} !~ /\bGDBM_File\b/) { 8 print "1..0 # Skip: GDBM_File was not built\n"; 9 exit 0; 10 } 11} 12 13use strict; 14use warnings; 15 16 17use GDBM_File; 18 19print "1..80\n"; 20 21unlink <Op.dbmx*>; 22 23umask(0); 24my %h ; 25print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n"); 26 27my $Dfile = "Op.dbmx.pag"; 28if (! -e $Dfile) { 29 ($Dfile) = <Op.dbmx*>; 30} 31if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin') { 32 print "ok 2 # Skipped: different file permission semantics\n"; 33} 34else { 35 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 36 $blksize,$blocks) = stat($Dfile); 37 print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); 38} 39my $i = 0; 40while (my ($key,$value) = each(%h)) { 41 $i++; 42} 43print (!$i ? "ok 3\n" : "not ok 3\n"); 44 45$h{'goner1'} = 'snork'; 46 47$h{'abc'} = 'ABC'; 48$h{'def'} = 'DEF'; 49$h{'jkl','mno'} = "JKL\034MNO"; 50$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); 51$h{'a'} = 'A'; 52$h{'b'} = 'B'; 53$h{'c'} = 'C'; 54$h{'d'} = 'D'; 55$h{'e'} = 'E'; 56$h{'f'} = 'F'; 57$h{'g'} = 'G'; 58$h{'h'} = 'H'; 59$h{'i'} = 'I'; 60 61$h{'goner2'} = 'snork'; 62delete $h{'goner2'}; 63 64untie(%h); 65print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 4\n" : "not ok 4\n"); 66 67$h{'j'} = 'J'; 68$h{'k'} = 'K'; 69$h{'l'} = 'L'; 70$h{'m'} = 'M'; 71$h{'n'} = 'N'; 72$h{'o'} = 'O'; 73$h{'p'} = 'P'; 74$h{'q'} = 'Q'; 75$h{'r'} = 'R'; 76$h{'s'} = 'S'; 77$h{'t'} = 'T'; 78$h{'u'} = 'U'; 79$h{'v'} = 'V'; 80$h{'w'} = 'W'; 81$h{'x'} = 'X'; 82$h{'y'} = 'Y'; 83$h{'z'} = 'Z'; 84 85$h{'goner3'} = 'snork'; 86 87delete $h{'goner1'}; 88delete $h{'goner3'}; 89 90my @keys = keys(%h); 91my @values = values(%h); 92 93if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} 94 95while (my ($key,$value) = each(%h)) { 96 if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { 97 $key =~ y/a-z/A-Z/; 98 $i++ if $key eq $value; 99 } 100} 101 102if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} 103 104@keys = ('blurfl', keys(%h), 'dyick'); 105if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} 106 107$h{'foo'} = ''; 108$h{''} = 'bar'; 109 110# check cache overflow and numeric keys and contents 111my $ok = 1; 112for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } 113for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } 114print ($ok ? "ok 8\n" : "not ok 8\n"); 115 116my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, 117 $blksize,$blocks) = stat($Dfile); 118print ($size > 0 ? "ok 9\n" : "not ok 9\n"); 119 120@h{0..200} = 200..400; 121my @foo = @h{0..200}; 122print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; 123 124print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); 125print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); 126 127untie %h; 128unlink 'Op.dbmx.dir', $Dfile; 129 130sub ok 131{ 132 my $no = shift ; 133 my $result = shift ; 134 135 print "not " unless $result ; 136 print "ok $no\n" ; 137} 138 139{ 140 # sub-class test 141 142 package Another ; 143 144 use strict ; 145 use warnings ; 146 147 open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; 148 print FILE <<'EOM' ; 149 150 package SubDB ; 151 152 use strict ; 153 use vars qw(@ISA @EXPORT) ; 154 155 require Exporter ; 156 use GDBM_File; 157 @ISA=qw(GDBM_File); 158 @EXPORT = @GDBM_File::EXPORT ; 159 160 sub STORE { 161 my $self = shift ; 162 my $key = shift ; 163 my $value = shift ; 164 $self->SUPER::STORE($key, $value * 2) ; 165 } 166 167 sub FETCH { 168 my $self = shift ; 169 my $key = shift ; 170 $self->SUPER::FETCH($key) - 1 ; 171 } 172 173 sub A_new_method 174 { 175 my $self = shift ; 176 my $key = shift ; 177 my $value = $self->FETCH($key) ; 178 return "[[$value]]" ; 179 } 180 181 1 ; 182EOM 183 184 close FILE ; 185 186 BEGIN { push @INC, '.'; } 187 unlink <dbhash.tmp*> ; 188 189 eval 'use SubDB ; '; 190 main::ok(13, $@ eq "") ; 191 my %h ; 192 my $X ; 193 eval ' 194 $X = tie(%h, "SubDB","dbhash.tmp", &GDBM_WRCREAT, 0640 ); 195 ' ; 196 197 main::ok(14, $@ eq "") ; 198 199 my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; 200 main::ok(15, $@ eq "") ; 201 main::ok(16, $ret == 5) ; 202 203 $ret = eval ' &GDBM_WRCREAT eq &main::GDBM_WRCREAT ' ; 204 main::ok(17, $@ eq "" ) ; 205 main::ok(18, $ret == 1) ; 206 207 $ret = eval '$X->A_new_method("fred") ' ; 208 main::ok(19, $@ eq "") ; 209 main::ok(20, $ret eq "[[5]]") ; 210 211 undef $X; 212 untie(%h); 213 unlink "SubDB.pm", <dbhash.tmp*> ; 214 215} 216 217{ 218 # DBM Filter tests 219 use strict ; 220 use warnings ; 221 my (%h, $db) ; 222 my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 223 224 sub checkOutput 225 { 226 my($fk, $sk, $fv, $sv) = @_ ; 227 return 228 $fetch_key eq $fk && $store_key eq $sk && 229 $fetch_value eq $fv && $store_value eq $sv && 230 $_ eq 'original' ; 231 } 232 233 unlink <Op.dbmx*>; 234 ok(21, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ; 235 236 $db->filter_fetch_key (sub { $fetch_key = $_ }) ; 237 $db->filter_store_key (sub { $store_key = $_ }) ; 238 $db->filter_fetch_value (sub { $fetch_value = $_}) ; 239 $db->filter_store_value (sub { $store_value = $_ }) ; 240 241 $_ = "original" ; 242 243 $h{"fred"} = "joe" ; 244 # fk sk fv sv 245 ok(22, checkOutput( "", "fred", "", "joe")) ; 246 247 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 248 ok(23, $h{"fred"} eq "joe"); 249 # fk sk fv sv 250 ok(24, checkOutput( "", "fred", "joe", "")) ; 251 252 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 253 ok(25, $db->FIRSTKEY() eq "fred") ; 254 # fk sk fv sv 255 ok(26, checkOutput( "fred", "", "", "")) ; 256 257 # replace the filters, but remember the previous set 258 my ($old_fk) = $db->filter_fetch_key 259 (sub { $_ = uc $_ ; $fetch_key = $_ }) ; 260 my ($old_sk) = $db->filter_store_key 261 (sub { $_ = lc $_ ; $store_key = $_ }) ; 262 my ($old_fv) = $db->filter_fetch_value 263 (sub { $_ = "[$_]"; $fetch_value = $_ }) ; 264 my ($old_sv) = $db->filter_store_value 265 (sub { s/o/x/g; $store_value = $_ }) ; 266 267 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 268 $h{"Fred"} = "Joe" ; 269 # fk sk fv sv 270 ok(27, checkOutput( "", "fred", "", "Jxe")) ; 271 272 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 273 ok(28, $h{"Fred"} eq "[Jxe]"); 274 # fk sk fv sv 275 ok(29, checkOutput( "", "fred", "[Jxe]", "")) ; 276 277 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 278 ok(30, $db->FIRSTKEY() eq "FRED") ; 279 # fk sk fv sv 280 ok(31, checkOutput( "FRED", "", "", "")) ; 281 282 # put the original filters back 283 $db->filter_fetch_key ($old_fk); 284 $db->filter_store_key ($old_sk); 285 $db->filter_fetch_value ($old_fv); 286 $db->filter_store_value ($old_sv); 287 288 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 289 $h{"fred"} = "joe" ; 290 ok(32, checkOutput( "", "fred", "", "joe")) ; 291 292 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 293 ok(33, $h{"fred"} eq "joe"); 294 ok(34, checkOutput( "", "fred", "joe", "")) ; 295 296 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 297 ok(35, $db->FIRSTKEY() eq "fred") ; 298 ok(36, checkOutput( "fred", "", "", "")) ; 299 300 # delete the filters 301 $db->filter_fetch_key (undef); 302 $db->filter_store_key (undef); 303 $db->filter_fetch_value (undef); 304 $db->filter_store_value (undef); 305 306 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 307 $h{"fred"} = "joe" ; 308 ok(37, checkOutput( "", "", "", "")) ; 309 310 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 311 ok(38, $h{"fred"} eq "joe"); 312 ok(39, checkOutput( "", "", "", "")) ; 313 314 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 315 ok(40, $db->FIRSTKEY() eq "fred") ; 316 ok(41, checkOutput( "", "", "", "")) ; 317 318 undef $db ; 319 untie %h; 320 unlink <Op.dbmx*>; 321} 322 323{ 324 # DBM Filter with a closure 325 326 use strict ; 327 use warnings ; 328 my (%h, $db) ; 329 330 unlink <Op.dbmx*>; 331 ok(42, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ; 332 333 my %result = () ; 334 335 sub Closure 336 { 337 my ($name) = @_ ; 338 my $count = 0 ; 339 my @kept = () ; 340 341 return sub { ++$count ; 342 push @kept, $_ ; 343 $result{$name} = "$name - $count: [@kept]" ; 344 } 345 } 346 347 $db->filter_store_key(Closure("store key")) ; 348 $db->filter_store_value(Closure("store value")) ; 349 $db->filter_fetch_key(Closure("fetch key")) ; 350 $db->filter_fetch_value(Closure("fetch value")) ; 351 352 $_ = "original" ; 353 354 $h{"fred"} = "joe" ; 355 ok(43, $result{"store key"} eq "store key - 1: [fred]"); 356 ok(44, $result{"store value"} eq "store value - 1: [joe]"); 357 ok(45, !defined $result{"fetch key"} ); 358 ok(46, !defined $result{"fetch value"} ); 359 ok(47, $_ eq "original") ; 360 361 ok(48, $db->FIRSTKEY() eq "fred") ; 362 ok(49, $result{"store key"} eq "store key - 1: [fred]"); 363 ok(50, $result{"store value"} eq "store value - 1: [joe]"); 364 ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]"); 365 ok(52, ! defined $result{"fetch value"} ); 366 ok(53, $_ eq "original") ; 367 368 $h{"jim"} = "john" ; 369 ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); 370 ok(55, $result{"store value"} eq "store value - 2: [joe john]"); 371 ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); 372 ok(57, ! defined $result{"fetch value"} ); 373 ok(58, $_ eq "original") ; 374 375 ok(59, $h{"fred"} eq "joe"); 376 ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]"); 377 ok(61, $result{"store value"} eq "store value - 2: [joe john]"); 378 ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]"); 379 ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]"); 380 ok(64, $_ eq "original") ; 381 382 undef $db ; 383 untie %h; 384 unlink <Op.dbmx*>; 385} 386 387{ 388 # DBM Filter recursion detection 389 use strict ; 390 use warnings ; 391 my (%h, $db) ; 392 unlink <Op.dbmx*>; 393 394 ok(65, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ; 395 396 $db->filter_store_key (sub { $_ = $h{$_} }) ; 397 398 eval '$h{1} = 1234' ; 399 ok(66, $@ =~ /^recursion detected in filter_store_key at/ ); 400 401 undef $db ; 402 untie %h; 403 unlink <Op.dbmx*>; 404} 405 406{ 407 # Bug ID 20001013.009 408 # 409 # test that $hash{KEY} = undef doesn't produce the warning 410 # Use of uninitialized value in null operation 411 use warnings ; 412 use strict ; 413 use GDBM_File ; 414 415 unlink <Op.dbmx*>; 416 my %h ; 417 my $a = ""; 418 local $SIG{__WARN__} = sub {$a = $_[0]} ; 419 420 ok(67, tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)); 421 $h{ABC} = undef; 422 ok(68, $a eq "") ; 423 untie %h; 424 unlink <Op.dbmx*>; 425} 426 427{ 428 # When iterating over a tied hash using "each", the key passed to FETCH 429 # will be recycled and passed to NEXTKEY. If a Source Filter modifies the 430 # key in FETCH via a filter_fetch_key method we need to check that the 431 # modified key doesn't get passed to NEXTKEY. 432 # Also Test "keys" & "values" while we are at it. 433 434 use warnings ; 435 use strict ; 436 use GDBM_File ; 437 438 unlink <Op.dbmx*>; 439 my $bad_key = 0 ; 440 my %h = () ; 441 ok(69, my $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)); 442 $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ; 443 $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ; 444 445 $h{'Alpha_ABC'} = 2 ; 446 $h{'Alpha_DEF'} = 5 ; 447 448 ok(70, $h{'Alpha_ABC'} == 2); 449 ok(71, $h{'Alpha_DEF'} == 5); 450 451 my ($k, $v) = ("",""); 452 while (($k, $v) = each %h) {} 453 ok(72, $bad_key == 0); 454 455 $bad_key = 0 ; 456 foreach $k (keys %h) {} 457 ok(73, $bad_key == 0); 458 459 $bad_key = 0 ; 460 foreach $v (values %h) {} 461 ok(74, $bad_key == 0); 462 463 undef $db ; 464 untie %h ; 465 unlink <Op.dbmx*>; 466} 467 468{ 469 # Check that DBM Filter can cope with read-only $_ 470 471 use warnings ; 472 use strict ; 473 my %h ; 474 unlink <Op.dbmx*>; 475 476 ok(75, my $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)); 477 478 $db->filter_fetch_key (sub { }) ; 479 $db->filter_store_key (sub { }) ; 480 $db->filter_fetch_value (sub { }) ; 481 $db->filter_store_value (sub { }) ; 482 483 $_ = "original" ; 484 485 $h{"fred"} = "joe" ; 486 ok(76, $h{"fred"} eq "joe"); 487 488 eval { my @r= grep { $h{$_} } (1, 2, 3) }; 489 ok (77, ! $@); 490 491 492 # delete the filters 493 $db->filter_fetch_key (undef); 494 $db->filter_store_key (undef); 495 $db->filter_fetch_value (undef); 496 $db->filter_store_value (undef); 497 498 $h{"fred"} = "joe" ; 499 500 ok(78, $h{"fred"} eq "joe"); 501 502 ok(79, $db->FIRSTKEY() eq "fred") ; 503 504 eval { my @r= grep { $h{$_} } (1, 2, 3) }; 505 ok (80, ! $@); 506 507 undef $db ; 508 untie %h; 509 unlink <Op.dbmx*>; 510} 511exit ; 512