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