1#!./perl -w 2 3use warnings; 4use strict; 5use Config; 6 7BEGIN { 8 if($ENV{PERL_CORE}) { 9 if ($Config{'extensions'} !~ /\bDB_File\b/ ) { 10 print "1..0 # Skip: DB_File was not built\n"; 11 exit 0; 12 } 13 } 14} 15 16use DB_File; 17use Fcntl; 18our ($dbh, $Dfile, $bad_ones, $FA); 19 20# full tied array support started in Perl 5.004_57 21# Double check to see if it is available. 22 23{ 24 sub try::TIEARRAY { bless [], "try" } 25 sub try::FETCHSIZE { $FA = 1 } 26 $FA = 0 ; 27 my @a ; 28 tie @a, 'try' ; 29 my $a = @a ; 30} 31 32 33sub ok 34{ 35 my $no = shift ; 36 my $result = shift ; 37 38 print "not " unless $result ; 39 print "ok $no\n" ; 40 41 return $result ; 42} 43 44{ 45 package Redirect ; 46 use Symbol ; 47 48 sub new 49 { 50 my $class = shift ; 51 my $filename = shift ; 52 my $fh = gensym ; 53 open ($fh, ">$filename") || die "Cannot open $filename: $!" ; 54 my $real_stdout = select($fh) ; 55 return bless [$fh, $real_stdout ] ; 56 57 } 58 sub DESTROY 59 { 60 my $self = shift ; 61 close $self->[0] ; 62 select($self->[1]) ; 63 } 64} 65 66sub docat 67{ 68 my $file = shift; 69 local $/ = undef; 70 open(CAT,$file) || die "Cannot open $file:$!"; 71 my $result = <CAT>; 72 close(CAT); 73 normalise($result) ; 74 return $result; 75} 76 77sub docat_del 78{ 79 my $file = shift; 80 my $result = docat($file); 81 unlink $file ; 82 return $result; 83} 84 85sub safeUntie 86{ 87 my $hashref = shift ; 88 my $no_inner = 1; 89 local $SIG{__WARN__} = sub {-- $no_inner } ; 90 untie @$hashref; 91 return $no_inner; 92} 93 94sub bad_one 95{ 96 unless ($bad_ones++) { 97 print STDERR <<EOM ; 98# 99# Some older versions of Berkeley DB version 1 will fail db-recno 100# tests 61, 63, 64 and 65. 101EOM 102 if ($^O eq 'darwin' 103 && $Config{db_version_major} == 1 104 && $Config{db_version_minor} == 0 105 && $Config{db_version_patch} == 0) { 106 print STDERR <<EOM ; 107# 108# For example Mac OS X 10.2 (or earlier) has such an old 109# version of Berkeley DB. 110EOM 111 } 112 113 print STDERR <<EOM ; 114# 115# You can safely ignore the errors if you're never going to use the 116# broken functionality (recno databases with a modified bval). 117# Otherwise you'll have to upgrade your DB library. 118# 119# If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the 120# last versions that were released. Berkeley DB version 2 is continually 121# being updated -- Check out http://www.sleepycat.com/ for more details. 122# 123EOM 124 } 125} 126 127sub normalise 128{ 129 return unless $^O eq 'cygwin' ; 130 foreach (@_) 131 { s#\r\n#\n#g } 132} 133 134BEGIN 135{ 136 { 137 local $SIG{__DIE__} ; 138 eval { require Data::Dumper ; import Data::Dumper } ; 139 } 140 141 if ($@) { 142 *Dumper = sub { my $a = shift; return "[ @{ $a } ]" } ; 143 } 144} 145 146my $splice_tests = 10 + 12 + 1; # ten regressions, plus the randoms 147my $total_tests = 181 ; 148$total_tests += $splice_tests if $FA ; 149print "1..$total_tests\n"; 150 151$Dfile = "recno.tmp"; 152unlink $Dfile ; 153 154umask(0); 155 156# Check the interface to RECNOINFO 157 158$dbh = new DB_File::RECNOINFO ; 159ok(1, ! defined $dbh->{bval}) ; 160ok(2, ! defined $dbh->{cachesize}) ; 161ok(3, ! defined $dbh->{psize}) ; 162ok(4, ! defined $dbh->{flags}) ; 163ok(5, ! defined $dbh->{lorder}) ; 164ok(6, ! defined $dbh->{reclen}) ; 165ok(7, ! defined $dbh->{bfname}) ; 166 167$dbh->{bval} = 3000 ; 168ok(8, $dbh->{bval} == 3000 ); 169 170$dbh->{cachesize} = 9000 ; 171ok(9, $dbh->{cachesize} == 9000 ); 172 173$dbh->{psize} = 400 ; 174ok(10, $dbh->{psize} == 400 ); 175 176$dbh->{flags} = 65 ; 177ok(11, $dbh->{flags} == 65 ); 178 179$dbh->{lorder} = 123 ; 180ok(12, $dbh->{lorder} == 123 ); 181 182$dbh->{reclen} = 1234 ; 183ok(13, $dbh->{reclen} == 1234 ); 184 185$dbh->{bfname} = 1234 ; 186ok(14, $dbh->{bfname} == 1234 ); 187 188 189# Check that an invalid entry is caught both for store & fetch 190eval '$dbh->{fred} = 1234' ; 191ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ ); 192eval 'my $q = $dbh->{fred}' ; 193ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ); 194 195# Now check the interface to RECNOINFO 196 197my $X ; 198my @h ; 199ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; 200 201my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ; 202 203ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) 204 || $noMode{$^O} ); 205 206#my $l = @h ; 207my $l = $X->length ; 208ok(19, ($FA ? @h == 0 : !$l) ); 209 210my @data = qw( a b c d ever f g h i j k longername m n o p) ; 211 212$h[0] = shift @data ; 213ok(20, $h[0] eq 'a' ); 214 215my $ i; 216foreach (@data) 217 { $h[++$i] = $_ } 218 219unshift (@data, 'a') ; 220 221ok(21, defined $h[1] ); 222ok(22, ! defined $h[16] ); 223ok(23, $FA ? @h == @data : $X->length == @data ); 224 225 226# Overwrite an entry & check fetch it 227$h[3] = 'replaced' ; 228$data[3] = 'replaced' ; 229ok(24, $h[3] eq 'replaced' ); 230 231#PUSH 232my @push_data = qw(added to the end) ; 233($FA ? push(@h, @push_data) : $X->push(@push_data)) ; 234push (@data, @push_data) ; 235ok(25, $h[++$i] eq 'added' ); 236ok(26, $h[++$i] eq 'to' ); 237ok(27, $h[++$i] eq 'the' ); 238ok(28, $h[++$i] eq 'end' ); 239 240# POP 241my $popped = pop (@data) ; 242my $value = ($FA ? pop @h : $X->pop) ; 243ok(29, $value eq $popped) ; 244 245# SHIFT 246$value = ($FA ? shift @h : $X->shift) ; 247my $shifted = shift @data ; 248ok(30, $value eq $shifted ); 249 250# UNSHIFT 251 252# empty list 253($FA ? unshift @h,() : $X->unshift) ; 254ok(31, ($FA ? @h == @data : $X->length == @data )); 255 256my @new_data = qw(add this to the start of the array) ; 257$FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ; 258unshift (@data, @new_data) ; 259ok(32, $FA ? @h == @data : $X->length == @data ); 260ok(33, $h[0] eq "add") ; 261ok(34, $h[1] eq "this") ; 262ok(35, $h[2] eq "to") ; 263ok(36, $h[3] eq "the") ; 264ok(37, $h[4] eq "start") ; 265ok(38, $h[5] eq "of") ; 266ok(39, $h[6] eq "the") ; 267ok(40, $h[7] eq "array") ; 268ok(41, $h[8] eq $data[8]) ; 269 270# Brief test for SPLICE - more thorough 'soak test' is later. 271my @old; 272if ($FA) { 273 @old = splice(@h, 1, 2, qw(bananas just before)); 274} 275else { 276 @old = $X->splice(1, 2, qw(bananas just before)); 277} 278ok(42, $h[0] eq "add") ; 279ok(43, $h[1] eq "bananas") ; 280ok(44, $h[2] eq "just") ; 281ok(45, $h[3] eq "before") ; 282ok(46, $h[4] eq "the") ; 283ok(47, $h[5] eq "start") ; 284ok(48, $h[6] eq "of") ; 285ok(49, $h[7] eq "the") ; 286ok(50, $h[8] eq "array") ; 287ok(51, $h[9] eq $data[8]) ; 288$FA ? splice(@h, 1, 3, @old) : $X->splice(1, 3, @old); 289 290# Now both arrays should be identical 291 292my $ok = 1 ; 293my $j = 0 ; 294foreach (@data) 295{ 296 $ok = 0, last if $_ ne $h[$j ++] ; 297} 298ok(52, $ok ); 299 300# Neagtive subscripts 301 302# get the last element of the array 303ok(53, $h[-1] eq $data[-1] ); 304ok(54, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] ); 305 306# get the first element using a negative subscript 307eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ; 308ok(55, $@ eq "" ); 309ok(56, $h[0] eq "abcd" ); 310 311# now try to read before the start of the array 312eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ; 313ok(57, $@ =~ '^Modification of non-creatable array value attempted' ); 314 315# IMPORTANT - $X must be undefined before the untie otherwise the 316# underlying DB close routine will not get called. 317undef $X ; 318ok(58, safeUntie \@h); 319 320unlink $Dfile; 321 322 323{ 324 # Check bval defaults to \n 325 326 my @h = () ; 327 my $dbh = new DB_File::RECNOINFO ; 328 ok(59, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; 329 $h[0] = "abc" ; 330 $h[1] = "def" ; 331 $h[3] = "ghi" ; 332 ok(60, safeUntie \@h); 333 my $x = docat($Dfile) ; 334 unlink $Dfile; 335 ok(61, $x eq "abc\ndef\n\nghi\n") ; 336} 337 338{ 339 # Change bval 340 341 my @h = () ; 342 my $dbh = new DB_File::RECNOINFO ; 343 $dbh->{bval} = "-" ; 344 ok(62, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; 345 $h[0] = "abc" ; 346 $h[1] = "def" ; 347 $h[3] = "ghi" ; 348 ok(63, safeUntie \@h); 349 my $x = docat($Dfile) ; 350 unlink $Dfile; 351 my $ok = ($x eq "abc-def--ghi-") ; 352 bad_one() unless $ok ; 353 ok(64, $ok) ; 354} 355 356{ 357 # Check R_FIXEDLEN with default bval (space) 358 359 my @h = () ; 360 my $dbh = new DB_File::RECNOINFO ; 361 $dbh->{flags} = R_FIXEDLEN ; 362 $dbh->{reclen} = 5 ; 363 ok(65, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; 364 $h[0] = "abc" ; 365 $h[1] = "def" ; 366 $h[3] = "ghi" ; 367 ok(66, safeUntie \@h); 368 my $x = docat($Dfile) ; 369 unlink $Dfile; 370 my $ok = ($x eq "abc def ghi ") ; 371 bad_one() unless $ok ; 372 ok(67, $ok) ; 373} 374 375{ 376 # Check R_FIXEDLEN with user-defined bval 377 378 my @h = () ; 379 my $dbh = new DB_File::RECNOINFO ; 380 $dbh->{flags} = R_FIXEDLEN ; 381 $dbh->{bval} = "-" ; 382 $dbh->{reclen} = 5 ; 383 ok(68, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; 384 $h[0] = "abc" ; 385 $h[1] = "def" ; 386 $h[3] = "ghi" ; 387 ok(69, safeUntie \@h); 388 my $x = docat($Dfile) ; 389 unlink $Dfile; 390 my $ok = ($x eq "abc--def-------ghi--") ; 391 bad_one() unless $ok ; 392 ok(70, $ok) ; 393} 394 395{ 396 # check that attempting to tie an associative array to a DB_RECNO will fail 397 398 my $filename = "xyz" ; 399 my %x ; 400 eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; 401 ok(71, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; 402 unlink $filename ; 403} 404 405{ 406 # sub-class test 407 408 package Another ; 409 410 use warnings ; 411 use strict ; 412 413 open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; 414 print FILE <<'EOM' ; 415 416 package SubDB ; 417 418 use warnings ; 419 use strict ; 420 our (@ISA, @EXPORT); 421 422 require Exporter ; 423 use DB_File; 424 @ISA=qw(DB_File); 425 @EXPORT = @DB_File::EXPORT ; 426 427 sub STORE { 428 my $self = shift ; 429 my $key = shift ; 430 my $value = shift ; 431 $self->SUPER::STORE($key, $value * 2) ; 432 } 433 434 sub FETCH { 435 my $self = shift ; 436 my $key = shift ; 437 $self->SUPER::FETCH($key) - 1 ; 438 } 439 440 sub put { 441 my $self = shift ; 442 my $key = shift ; 443 my $value = shift ; 444 $self->SUPER::put($key, $value * 3) ; 445 } 446 447 sub get { 448 my $self = shift ; 449 $self->SUPER::get($_[0], $_[1]) ; 450 $_[1] -= 2 ; 451 } 452 453 sub A_new_method 454 { 455 my $self = shift ; 456 my $key = shift ; 457 my $value = $self->FETCH($key) ; 458 return "[[$value]]" ; 459 } 460 461 1 ; 462EOM 463 464 close FILE or die "Could not close: $!"; 465 466 BEGIN { push @INC, '.'; } 467 eval 'use SubDB ; '; 468 main::ok(72, $@ eq "") ; 469 my @h ; 470 my $X ; 471 eval ' 472 $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); 473 ' ; 474 die "Could not tie: $!" unless $X; 475 476 main::ok(73, $@ eq "") ; 477 478 my $ret = eval '$h[3] = 3 ; return $h[3] ' ; 479 main::ok(74, $@ eq "") ; 480 main::ok(75, $ret == 5) ; 481 482 my $value = 0; 483 $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; 484 main::ok(76, $@ eq "") ; 485 main::ok(77, $ret == 10) ; 486 487 $ret = eval ' R_NEXT eq main::R_NEXT ' ; 488 main::ok(78, $@ eq "" ) ; 489 main::ok(79, $ret == 1) ; 490 491 $ret = eval '$X->A_new_method(1) ' ; 492 main::ok(80, $@ eq "") ; 493 main::ok(81, $ret eq "[[11]]") ; 494 495 undef $X; 496 main::ok(82, main::safeUntie \@h); 497 unlink "SubDB.pm", "recno.tmp" ; 498 499} 500 501{ 502 503 # test $# 504 my $self ; 505 unlink $Dfile; 506 ok(83, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; 507 $h[0] = "abc" ; 508 $h[1] = "def" ; 509 $h[2] = "ghi" ; 510 $h[3] = "jkl" ; 511 ok(84, $FA ? $#h == 3 : $self->length() == 4) ; 512 undef $self ; 513 ok(85, safeUntie \@h); 514 my $x = docat($Dfile) ; 515 ok(86, $x eq "abc\ndef\nghi\njkl\n") ; 516 517 # $# sets array to same length 518 $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ; 519 ok(87, $self) 520 or warn "# $DB_File::Error\n"; 521 if ($FA) 522 { $#h = 3 } 523 else 524 { $self->STORESIZE(4) } 525 ok(88, $FA ? $#h == 3 : $self->length() == 4) ; 526 undef $self ; 527 ok(89, safeUntie \@h); 528 $x = docat($Dfile) ; 529 ok(90, $x eq "abc\ndef\nghi\njkl\n") ; 530 531 # $# sets array to bigger 532 ok(91, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; 533 if ($FA) 534 { $#h = 6 } 535 else 536 { $self->STORESIZE(7) } 537 ok(92, $FA ? $#h == 6 : $self->length() == 7) ; 538 undef $self ; 539 ok(93, safeUntie \@h); 540 $x = docat($Dfile) ; 541 ok(94, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; 542 543 # $# sets array smaller 544 ok(95, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; 545 if ($FA) 546 { $#h = 2 } 547 else 548 { $self->STORESIZE(3) } 549 ok(96, $FA ? $#h == 2 : $self->length() == 3) ; 550 undef $self ; 551 ok(97, safeUntie \@h); 552 $x = docat($Dfile) ; 553 ok(98, $x eq "abc\ndef\nghi\n") ; 554 555 unlink $Dfile; 556 557 558} 559 560{ 561 # DBM Filter tests 562 use warnings ; 563 use strict ; 564 my (@h, $db) ; 565 my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 566 unlink $Dfile; 567 568 sub checkOutput 569 { 570 my($fk, $sk, $fv, $sv) = @_ ; 571 572 print "# Fetch Key : expected '$fk' got '$fetch_key'\n" 573 if $fetch_key ne $fk ; 574 print "# Fetch Value : expected '$fv' got '$fetch_value'\n" 575 if $fetch_value ne $fv ; 576 print "# Store Key : expected '$sk' got '$store_key'\n" 577 if $store_key ne $sk ; 578 print "# Store Value : expected '$sv' got '$store_value'\n" 579 if $store_value ne $sv ; 580 print "# \$_ : expected 'original' got '$_'\n" 581 if $_ ne 'original' ; 582 583 return 584 $fetch_key eq $fk && $store_key eq $sk && 585 $fetch_value eq $fv && $store_value eq $sv && 586 $_ eq 'original' ; 587 } 588 589 ok(99, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); 590 591 $db->filter_fetch_key (sub { $fetch_key = $_ }) ; 592 $db->filter_store_key (sub { $store_key = $_ }) ; 593 $db->filter_fetch_value (sub { $fetch_value = $_}) ; 594 $db->filter_store_value (sub { $store_value = $_ }) ; 595 596 $_ = "original" ; 597 598 $h[0] = "joe" ; 599 # fk sk fv sv 600 ok(100, checkOutput( "", 0, "", "joe")) ; 601 602 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 603 ok(101, $h[0] eq "joe"); 604 # fk sk fv sv 605 ok(102, checkOutput( "", 0, "joe", "")) ; 606 607 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 608 ok(103, $db->FIRSTKEY() == 0) ; 609 # fk sk fv sv 610 ok(104, checkOutput( 0, "", "", "")) ; 611 612 # replace the filters, but remember the previous set 613 my ($old_fk) = $db->filter_fetch_key 614 (sub { ++ $_ ; $fetch_key = $_ }) ; 615 my ($old_sk) = $db->filter_store_key 616 (sub { $_ *= 2 ; $store_key = $_ }) ; 617 my ($old_fv) = $db->filter_fetch_value 618 (sub { $_ = "[$_]"; $fetch_value = $_ }) ; 619 my ($old_sv) = $db->filter_store_value 620 (sub { s/o/x/g; $store_value = $_ }) ; 621 622 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 623 $h[1] = "Joe" ; 624 # fk sk fv sv 625 ok(105, checkOutput( "", 2, "", "Jxe")) ; 626 627 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 628 ok(106, $h[1] eq "[Jxe]"); 629 # fk sk fv sv 630 ok(107, checkOutput( "", 2, "[Jxe]", "")) ; 631 632 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 633 ok(108, $db->FIRSTKEY() == 1) ; 634 # fk sk fv sv 635 ok(109, checkOutput( 1, "", "", "")) ; 636 637 # put the original filters back 638 $db->filter_fetch_key ($old_fk); 639 $db->filter_store_key ($old_sk); 640 $db->filter_fetch_value ($old_fv); 641 $db->filter_store_value ($old_sv); 642 643 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 644 $h[0] = "joe" ; 645 ok(110, checkOutput( "", 0, "", "joe")) ; 646 647 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 648 ok(111, $h[0] eq "joe"); 649 ok(112, checkOutput( "", 0, "joe", "")) ; 650 651 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 652 ok(113, $db->FIRSTKEY() == 0) ; 653 ok(114, checkOutput( 0, "", "", "")) ; 654 655 # delete the filters 656 $db->filter_fetch_key (undef); 657 $db->filter_store_key (undef); 658 $db->filter_fetch_value (undef); 659 $db->filter_store_value (undef); 660 661 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 662 $h[0] = "joe" ; 663 ok(115, checkOutput( "", "", "", "")) ; 664 665 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 666 ok(116, $h[0] eq "joe"); 667 ok(117, checkOutput( "", "", "", "")) ; 668 669 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; 670 ok(118, $db->FIRSTKEY() == 0) ; 671 ok(119, checkOutput( "", "", "", "")) ; 672 673 undef $db ; 674 ok(120, safeUntie \@h); 675 unlink $Dfile; 676} 677 678{ 679 # DBM Filter with a closure 680 681 use warnings ; 682 use strict ; 683 my (@h, $db) ; 684 685 unlink $Dfile; 686 ok(121, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); 687 688 my %result = () ; 689 690 sub Closure 691 { 692 my ($name) = @_ ; 693 my $count = 0 ; 694 my @kept = () ; 695 696 return sub { ++$count ; 697 push @kept, $_ ; 698 $result{$name} = "$name - $count: [@kept]" ; 699 } 700 } 701 702 $db->filter_store_key(Closure("store key")) ; 703 $db->filter_store_value(Closure("store value")) ; 704 $db->filter_fetch_key(Closure("fetch key")) ; 705 $db->filter_fetch_value(Closure("fetch value")) ; 706 707 $_ = "original" ; 708 709 $h[0] = "joe" ; 710 ok(122, $result{"store key"} eq "store key - 1: [0]"); 711 ok(123, $result{"store value"} eq "store value - 1: [joe]"); 712 ok(124, ! defined $result{"fetch key"} ); 713 ok(125, ! defined $result{"fetch value"} ); 714 ok(126, $_ eq "original") ; 715 716 ok(127, $db->FIRSTKEY() == 0 ) ; 717 ok(128, $result{"store key"} eq "store key - 1: [0]"); 718 ok(129, $result{"store value"} eq "store value - 1: [joe]"); 719 ok(130, $result{"fetch key"} eq "fetch key - 1: [0]"); 720 ok(131, ! defined $result{"fetch value"} ); 721 ok(132, $_ eq "original") ; 722 723 $h[7] = "john" ; 724 ok(133, $result{"store key"} eq "store key - 2: [0 7]"); 725 ok(134, $result{"store value"} eq "store value - 2: [joe john]"); 726 ok(135, $result{"fetch key"} eq "fetch key - 1: [0]"); 727 ok(136, ! defined $result{"fetch value"} ); 728 ok(137, $_ eq "original") ; 729 730 ok(138, $h[0] eq "joe"); 731 ok(139, $result{"store key"} eq "store key - 3: [0 7 0]"); 732 ok(140, $result{"store value"} eq "store value - 2: [joe john]"); 733 ok(141, $result{"fetch key"} eq "fetch key - 1: [0]"); 734 ok(142, $result{"fetch value"} eq "fetch value - 1: [joe]"); 735 ok(143, $_ eq "original") ; 736 737 undef $db ; 738 ok(144, safeUntie \@h); 739 unlink $Dfile; 740} 741 742{ 743 # DBM Filter recursion detection 744 use warnings ; 745 use strict ; 746 my (@h, $db) ; 747 unlink $Dfile; 748 749 ok(145, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); 750 751 $db->filter_store_key (sub { $_ = $h[0] }) ; 752 753 eval '$h[1] = 1234' ; 754 ok(146, $@ =~ /^recursion detected in filter_store_key at/ ); 755 756 undef $db ; 757 ok(147, safeUntie \@h); 758 unlink $Dfile; 759} 760 761 762{ 763 # Examples from the POD 764 765 my $file = "xyzt" ; 766 { 767 my $redirect = new Redirect $file ; 768 769 use warnings FATAL => qw(all); 770 use strict ; 771 use DB_File ; 772 773 my $filename = "text" ; 774 unlink $filename ; 775 776 my @h ; 777 my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO 778 or die "Cannot open file 'text': $!\n" ; 779 780 # Add a few key/value pairs to the file 781 $h[0] = "orange" ; 782 $h[1] = "blue" ; 783 $h[2] = "yellow" ; 784 785 $FA ? push @h, "green", "black" 786 : $x->push("green", "black") ; 787 788 my $elements = $FA ? scalar @h : $x->length ; 789 print "The array contains $elements entries\n" ; 790 791 my $last = $FA ? pop @h : $x->pop ; 792 print "popped $last\n" ; 793 794 $FA ? unshift @h, "white" 795 : $x->unshift("white") ; 796 my $first = $FA ? shift @h : $x->shift ; 797 print "shifted $first\n" ; 798 799 # Check for existence of a key 800 print "Element 1 Exists with value $h[1]\n" if $h[1] ; 801 802 # use a negative index 803 print "The last element is $h[-1]\n" ; 804 print "The 2nd last element is $h[-2]\n" ; 805 806 undef $x ; 807 untie @h ; 808 809 unlink $filename ; 810 } 811 812 ok(148, docat_del($file) eq <<'EOM') ; 813The array contains 5 entries 814popped black 815shifted white 816Element 1 Exists with value blue 817The last element is green 818The 2nd last element is yellow 819EOM 820 821 my $save_output = "xyzt" ; 822 { 823 my $redirect = new Redirect $save_output ; 824 825 use warnings FATAL => qw(all); 826 use strict ; 827 our (@h, $H, $file, $i); 828 use DB_File ; 829 use Fcntl ; 830 831 $file = "text" ; 832 833 unlink $file ; 834 835 $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO 836 or die "Cannot open file $file: $!\n" ; 837 838 # first create a text file to play with 839 $h[0] = "zero" ; 840 $h[1] = "one" ; 841 $h[2] = "two" ; 842 $h[3] = "three" ; 843 $h[4] = "four" ; 844 845 846 # Print the records in order. 847 # 848 # The length method is needed here because evaluating a tied 849 # array in a scalar context does not return the number of 850 # elements in the array. 851 852 print "\nORIGINAL\n" ; 853 foreach $i (0 .. $H->length - 1) { 854 print "$i: $h[$i]\n" ; 855 } 856 857 # use the push & pop methods 858 $a = $H->pop ; 859 $H->push("last") ; 860 print "\nThe last record was [$a]\n" ; 861 862 # and the shift & unshift methods 863 $a = $H->shift ; 864 $H->unshift("first") ; 865 print "The first record was [$a]\n" ; 866 867 # Use the API to add a new record after record 2. 868 $i = 2 ; 869 $H->put($i, "Newbie", R_IAFTER) ; 870 871 # and a new record before record 1. 872 $i = 1 ; 873 $H->put($i, "New One", R_IBEFORE) ; 874 875 # delete record 3 876 $H->del(3) ; 877 878 # now print the records in reverse order 879 print "\nREVERSE\n" ; 880 for ($i = $H->length - 1 ; $i >= 0 ; -- $i) 881 { print "$i: $h[$i]\n" } 882 883 # same again, but use the API functions instead 884 print "\nREVERSE again\n" ; 885 my ($s, $k, $v) = (0, 0, 0) ; 886 for ($s = $H->seq($k, $v, R_LAST) ; 887 $s == 0 ; 888 $s = $H->seq($k, $v, R_PREV)) 889 { print "$k: $v\n" } 890 891 undef $H ; 892 untie @h ; 893 894 unlink $file ; 895 } 896 897 ok(149, docat_del($save_output) eq <<'EOM') ; 898 899ORIGINAL 9000: zero 9011: one 9022: two 9033: three 9044: four 905 906The last record was [four] 907The first record was [zero] 908 909REVERSE 9105: last 9114: three 9123: Newbie 9132: one 9141: New One 9150: first 916 917REVERSE again 9185: last 9194: three 9203: Newbie 9212: one 9221: New One 9230: first 924EOM 925 926} 927 928{ 929 # Bug ID 20001013.009 930 # 931 # test that $hash{KEY} = undef doesn't produce the warning 932 # Use of uninitialized value in null operation 933 use warnings ; 934 use strict ; 935 use DB_File ; 936 937 unlink $Dfile; 938 my @h ; 939 my $a = ""; 940 local $SIG{__WARN__} = sub {$a = $_[0]} ; 941 942 tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 943 or die "Can't open file: $!\n" ; 944 $h[0] = undef; 945 ok(150, $a eq "") ; 946 ok(151, safeUntie \@h); 947 unlink $Dfile; 948} 949 950{ 951 # test that %hash = () doesn't produce the warning 952 # Argument "" isn't numeric in entersub 953 use warnings ; 954 use strict ; 955 use DB_File ; 956 my $a = ""; 957 local $SIG{__WARN__} = sub {$a = $_[0]} ; 958 959 unlink $Dfile; 960 my @h ; 961 962 tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 963 or die "Can't open file: $!\n" ; 964 @h = (); ; 965 ok(152, $a eq "") ; 966 ok(153, safeUntie \@h); 967 unlink $Dfile; 968} 969 970{ 971 # Check that DBM Filter can cope with read-only $_ 972 973 use warnings ; 974 use strict ; 975 my (@h, $db) ; 976 unlink $Dfile; 977 978 ok(154, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); 979 980 $db->filter_fetch_key (sub { }) ; 981 $db->filter_store_key (sub { }) ; 982 $db->filter_fetch_value (sub { }) ; 983 $db->filter_store_value (sub { }) ; 984 985 $_ = "original" ; 986 987 $h[0] = "joe" ; 988 ok(155, $h[0] eq "joe"); 989 990 eval { my @r= grep { $h[$_] } (1, 2, 3) }; 991 ok (156, ! $@); 992 993 994 # delete the filters 995 $db->filter_fetch_key (undef); 996 $db->filter_store_key (undef); 997 $db->filter_fetch_value (undef); 998 $db->filter_store_value (undef); 999 1000 $h[1] = "joe" ; 1001 1002 ok(157, $h[1] eq "joe"); 1003 1004 eval { my @r= grep { $h[$_] } (1, 2, 3) }; 1005 ok (158, ! $@); 1006 1007 undef $db ; 1008 untie @h; 1009 unlink $Dfile; 1010} 1011 1012{ 1013 # Check low-level API works with filter 1014 1015 use warnings ; 1016 use strict ; 1017 my (@h, $db) ; 1018 my $Dfile = "xxy.db"; 1019 unlink $Dfile; 1020 1021 ok(159, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); 1022 1023 1024 $db->filter_fetch_key (sub { ++ $_ } ); 1025 $db->filter_store_key (sub { -- $_ } ); 1026 $db->filter_fetch_value (sub { $_ = unpack("i", $_) } ); 1027 $db->filter_store_value (sub { $_ = pack("i", $_) } ); 1028 1029 $_ = 'fred'; 1030 1031 my $key = 22 ; 1032 my $value = 34 ; 1033 1034 $db->put($key, $value) ; 1035 ok 160, $key == 22; 1036 ok 161, $value == 34 ; 1037 ok 162, $_ eq 'fred'; 1038 #print "k [$key][$value]\n" ; 1039 1040 my $val ; 1041 $db->get($key, $val) ; 1042 ok 163, $key == 22; 1043 ok 164, $val == 34 ; 1044 ok 165, $_ eq 'fred'; 1045 1046 $key = 51 ; 1047 $value = 454; 1048 $h[$key] = $value ; 1049 ok 166, $key == 51; 1050 ok 167, $value == 454 ; 1051 ok 168, $_ eq 'fred'; 1052 1053 undef $db ; 1054 untie @h; 1055 unlink $Dfile; 1056} 1057 1058 1059{ 1060 # Regression Test for bug 30237 1061 # Check that substr can be used in the key to db_put 1062 # and that db_put does not trigger the warning 1063 # 1064 # Use of uninitialized value in subroutine entry 1065 1066 1067 use warnings ; 1068 use strict ; 1069 my (@h, $db) ; 1070 my $status ; 1071 my $Dfile = "xxy.db"; 1072 unlink $Dfile; 1073 1074 ok(169, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO) ); 1075 1076 my $warned = ''; 1077 local $SIG{__WARN__} = sub {$warned = $_[0]} ; 1078 1079 # db-put with substr of key 1080 my %remember = () ; 1081 for my $ix ( 0 .. 2 ) 1082 { 1083 my $key = $ix . "data" ; 1084 my $value = "value$ix" ; 1085 $remember{substr($key,0, 1)} = $value ; 1086 $db->put(substr($key,0, 1), $value) ; 1087 } 1088 1089 ok 170, $warned eq '' 1090 or print "# Caught warning [$warned]\n" ; 1091 1092 # db-put with substr of value 1093 $warned = ''; 1094 for my $ix ( 3 .. 5 ) 1095 { 1096 my $key = $ix . "data" ; 1097 my $value = "value$ix" ; 1098 $remember{$ix} = $value ; 1099 $db->put($ix, substr($value,0)) ; 1100 } 1101 1102 ok 171, $warned eq '' 1103 or print "# Caught warning [$warned]\n" ; 1104 1105 # via the tied array is not a problem, but check anyway 1106 # substr of key 1107 $warned = ''; 1108 for my $ix ( 6 .. 8 ) 1109 { 1110 my $key = $ix . "data" ; 1111 my $value = "value$ix" ; 1112 $remember{substr($key,0,1)} = $value ; 1113 $h[substr($key,0,1)] = $value ; 1114 } 1115 1116 ok 172, $warned eq '' 1117 or print "# Caught warning [$warned]\n" ; 1118 1119 # via the tied array is not a problem, but check anyway 1120 # substr of value 1121 $warned = ''; 1122 for my $ix ( 9 .. 10 ) 1123 { 1124 my $key = $ix . "data" ; 1125 my $value = "value$ix" ; 1126 $remember{$ix} = $value ; 1127 $h[$ix] = substr($value,0) ; 1128 } 1129 1130 ok 173, $warned eq '' 1131 or print "# Caught warning [$warned]\n" ; 1132 1133 my %bad = () ; 1134 my $key = ''; 1135 for (my $status = $db->seq($key, $value, R_FIRST ) ; 1136 $status == 0 ; 1137 $status = $db->seq($key, $value, R_NEXT ) ) { 1138 1139 #print "# key [$key] value [$value]\n" ; 1140 if (defined $remember{$key} && defined $value && 1141 $remember{$key} eq $value) { 1142 delete $remember{$key} ; 1143 } 1144 else { 1145 $bad{$key} = $value ; 1146 } 1147 } 1148 1149 ok 174, keys %bad == 0 ; 1150 ok 175, keys %remember == 0 ; 1151 1152 print "# missing -- $key $value\n" while ($key, $value) = each %remember; 1153 print "# bad -- $key $value\n" while ($key, $value) = each %bad; 1154 1155 # Make sure this fix does not break code to handle an undef key 1156 my $value = 'fred'; 1157 $warned = ''; 1158 $status = $db->put(undef, $value) ; 1159 ok 176, $status == 0 1160 or print "# put failed - status $status\n"; 1161 ok 177, $warned eq '' 1162 or print "# Caught warning [$warned]\n" ; 1163 $warned = ''; 1164 1165 print "# db_ver $DB_File::db_ver\n"; 1166 $value = '' ; 1167 $status = $db->get(undef, $value) ; 1168 ok 178, $status == 0 1169 or print "# get failed - status $status\n" ; 1170 ok(179, $db->get(undef, $value) == 0) or print "# get failed\n" ; 1171 ok 180, $value eq 'fred' or print "# got [$value]\n" ; 1172 ok 181, $warned eq '' 1173 or print "# Caught warning [$warned]\n" ; 1174 $warned = ''; 1175 1176 undef $db ; 1177 untie @h; 1178 unlink $Dfile; 1179} 1180 1181# Only test splice if this is a newish version of Perl 1182exit unless $FA ; 1183 1184# Test SPLICE 1185 1186{ 1187 # check that the splice warnings are under the same lexical control 1188 # as their non-tied counterparts. 1189 1190 use warnings; 1191 use strict; 1192 1193 my $a = ''; 1194 my @a = (1); 1195 local $SIG{__WARN__} = sub {$a = $_[0]} ; 1196 1197 unlink $Dfile; 1198 my @tied ; 1199 1200 tie @tied, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 1201 or die "Can't open file: $!\n" ; 1202 1203 # uninitialized offset 1204 use warnings; 1205 my $offset ; 1206 $a = ''; 1207 splice(@a, $offset); 1208 ok(182, $a =~ /^Use of uninitialized value /); 1209 $a = ''; 1210 splice(@tied, $offset); 1211 ok(183, $a =~ /^Use of uninitialized value in splice/); 1212 1213 no warnings 'uninitialized'; 1214 $a = ''; 1215 splice(@a, $offset); 1216 ok(184, $a eq ''); 1217 $a = ''; 1218 splice(@tied, $offset); 1219 ok(185, $a eq ''); 1220 1221 # uninitialized length 1222 use warnings; 1223 my $length ; 1224 $a = ''; 1225 splice(@a, 0, $length); 1226 ok(186, $a =~ /^Use of uninitialized value /); 1227 $a = ''; 1228 splice(@tied, 0, $length); 1229 ok(187, $a =~ /^Use of uninitialized value in splice/); 1230 1231 no warnings 'uninitialized'; 1232 $a = ''; 1233 splice(@a, 0, $length); 1234 ok(188, $a eq ''); 1235 $a = ''; 1236 splice(@tied, 0, $length); 1237 ok(189, $a eq ''); 1238 1239 # offset past end of array 1240 use warnings; 1241 $a = ''; 1242 splice(@a, 3); 1243 my $splice_end_array = ($a =~ /^splice\(\) offset past end of array/); 1244 $a = ''; 1245 splice(@tied, 3); 1246 ok(190, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/); 1247 1248 no warnings 'misc'; 1249 $a = ''; 1250 splice(@a, 3); 1251 ok(191, $a eq ''); 1252 $a = ''; 1253 splice(@tied, 3); 1254 ok(192, $a eq ''); 1255 1256 ok(193, safeUntie \@tied); 1257 unlink $Dfile; 1258} 1259 1260# 1261# These are a few regression tests: bundles of five arguments to pass 1262# to test_splice(). The first four arguments correspond to those 1263# given to splice(), and the last says which context to call it in 1264# (scalar, list or void). 1265# 1266# The expected result is not needed because we get that by running 1267# Perl's built-in splice(). 1268# 1269my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion', 1270 'rarely', 'paleness' ], 1271 -4, -2, 1272 [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ], 1273 'void' ], 1274 1275 [ [ 'a' ], -2, 1, [ 'B' ], 'void' ], 1276 1277 [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ], 1278 0, -4, 1279 [ 'maids' ], 1280 'void' ], 1281 1282 [ [ 'visibility', 'pocketful', 'rectangles' ], 1283 -10, 0, 1284 [ 'garbages' ], 1285 'void' ], 1286 1287 [ [ 'sleeplessly' ], 1288 8, -4, 1289 [ 'Margery', 'clearing', 'repercussion', 'clubs', 1290 'arise' ], 1291 'void' ], 1292 1293 [ [ 'chastises', 'recalculates' ], 1294 0, 0, 1295 [ 'momentariness', 'mediates', 'accents', 'toils', 1296 'regaled' ], 1297 'void' ], 1298 1299 [ [ 'b', '' ], 1300 9, 8, 1301 [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], 1302 'scalar' ], 1303 1304 [ [ 'b', '' ], 1305 undef, undef, 1306 [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], 1307 'scalar' ], 1308 1309 [ [ 'riheb' ], -8, undef, [], 'void' ], 1310 1311 [ [ 'uft', 'qnxs', '' ], 1312 6, -2, 1313 [ 'znp', 'mhnkh', 'bn' ], 1314 'void' ], 1315 ); 1316 1317my $testnum = 194; 1318my $failed = 0; 1319my $tmp = "dbr$$"; 1320foreach my $test (@tests) { 1321 my $err = test_splice(@$test); 1322 if (defined $err) { 1323 print STDERR "# failed: ", Dumper($test); 1324 print STDERR "# error: $err\n"; 1325 $failed = 1; 1326 ok($testnum++, 0); 1327 } 1328 else { ok($testnum++, 1) } 1329} 1330 1331if ($failed) { 1332 # Not worth running the random ones 1333 print STDERR '# skipping ', $testnum++, "\n"; 1334} 1335else { 1336 # A thousand randomly-generated tests 1337 $failed = 0; 1338 srand(0); 1339 foreach (0 .. 1000 - 1) { 1340 my $test = rand_test(); 1341 my $err = test_splice(@$test); 1342 if (defined $err) { 1343 print STDERR "# failed: ", Dumper($test); 1344 print STDERR "# error: $err\n"; 1345 $failed = 1; 1346 print STDERR "# skipping any remaining random tests\n"; 1347 last; 1348 } 1349 } 1350 1351 ok($testnum++, not $failed); 1352} 1353 1354die "testnum ($testnum) != total_tests ($total_tests) + 1" 1355 if $testnum != $total_tests + 1; 1356 1357exit ; 1358 1359# Subroutines for SPLICE testing 1360 1361# test_splice() 1362# 1363# Test the new splice() against Perl's built-in one. The first four 1364# parameters are those passed to splice(), except that the lists must 1365# be (explicitly) passed by reference, and are not actually modified. 1366# (It's just a test!) The last argument specifies the context in 1367# which to call the functions: 'list', 'scalar', or 'void'. 1368# 1369# Returns: 1370# undef, if the two splices give the same results for the given 1371# arguments and context; 1372# 1373# an error message showing the difference, otherwise. 1374# 1375# Reads global variable $tmp. 1376# 1377sub test_splice { 1378 die 'usage: test_splice(array, offset, length, list, context)' if @_ != 5; 1379 my ($array, $offset, $length, $list, $context) = @_; 1380 my @array = @$array; 1381 my @list = @$list; 1382 1383 unlink $tmp; 1384 1385 my @h; 1386 my $H = tie @h, 'DB_File', $tmp, O_CREAT|O_RDWR, 0644, $DB_RECNO 1387 or die "cannot open $tmp: $!"; 1388 1389 my $i = 0; 1390 foreach ( @array ) { $h[$i++] = $_ } 1391 1392 return "basic DB_File sanity check failed" 1393 if list_diff(\@array, \@h); 1394 1395 # Output from splice(): 1396 # Returned value (munged a bit), error msg, warnings 1397 # 1398 my ($s_r, $s_error, @s_warnings); 1399 1400 my $gather_warning = sub { push @s_warnings, $_[0] }; 1401 if ($context eq 'list') { 1402 my @r; 1403 eval { 1404 local $SIG{__WARN__} = $gather_warning; 1405 @r = splice @array, $offset, $length, @list; 1406 }; 1407 $s_error = $@; 1408 $s_r = \@r; 1409 } 1410 elsif ($context eq 'scalar') { 1411 my $r; 1412 eval { 1413 local $SIG{__WARN__} = $gather_warning; 1414 $r = splice @array, $offset, $length, @list; 1415 }; 1416 $s_error = $@; 1417 $s_r = [ $r ]; 1418 } 1419 elsif ($context eq 'void') { 1420 eval { 1421 local $SIG{__WARN__} = $gather_warning; 1422 splice @array, $offset, $length, @list; 1423 }; 1424 $s_error = $@; 1425 $s_r = []; 1426 } 1427 else { 1428 die "bad context $context"; 1429 } 1430 1431 foreach ($s_error, @s_warnings) { 1432 chomp; 1433 s/ at \S+ line \d+\.$//; 1434 # only built-in splice identifies name of uninit value 1435 s/(uninitialized value) \$\w+/$1/; 1436 } 1437 1438 # Now do the same for DB_File's version of splice 1439 my ($ms_r, $ms_error, @ms_warnings); 1440 $gather_warning = sub { push @ms_warnings, $_[0] }; 1441 if ($context eq 'list') { 1442 my @r; 1443 eval { 1444 local $SIG{__WARN__} = $gather_warning; 1445 @r = splice @h, $offset, $length, @list; 1446 }; 1447 $ms_error = $@; 1448 $ms_r = \@r; 1449 } 1450 elsif ($context eq 'scalar') { 1451 my $r; 1452 eval { 1453 local $SIG{__WARN__} = $gather_warning; 1454 $r = splice @h, $offset, $length, @list; 1455 }; 1456 $ms_error = $@; 1457 $ms_r = [ $r ]; 1458 } 1459 elsif ($context eq 'void') { 1460 eval { 1461 local $SIG{__WARN__} = $gather_warning; 1462 splice @h, $offset, $length, @list; 1463 }; 1464 $ms_error = $@; 1465 $ms_r = []; 1466 } 1467 else { 1468 die "bad context $context"; 1469 } 1470 1471 foreach ($ms_error, @ms_warnings) { 1472 chomp; 1473 s/ at \S+(\s+\S+)*? line \d+\.?.*//s; 1474 } 1475 1476 return "different errors: '$s_error' vs '$ms_error'" 1477 if $s_error ne $ms_error; 1478 return('different return values: ' . Dumper($s_r) . ' vs ' . Dumper($ms_r)) 1479 if list_diff($s_r, $ms_r); 1480 return('different changed list: ' . Dumper(\@array) . ' vs ' . Dumper(\@h)) 1481 if list_diff(\@array, \@h); 1482 1483 if ((scalar @s_warnings) != (scalar @ms_warnings)) { 1484 return 'different number of warnings'; 1485 } 1486 1487 while (@s_warnings) { 1488 my $sw = shift @s_warnings; 1489 my $msw = shift @ms_warnings; 1490 1491 if (defined $sw and defined $msw) { 1492 $msw =~ s/ \(.+\)$//; 1493 $msw =~ s/ in splice$// if $] < 5.006; 1494 if ($sw ne $msw) { 1495 return "different warning: '$sw' vs '$msw'"; 1496 } 1497 } 1498 elsif (not defined $sw and not defined $msw) { 1499 # Okay. 1500 } 1501 else { 1502 return "one warning defined, another undef"; 1503 } 1504 } 1505 1506 undef $H; 1507 untie @h; 1508 1509 open(TEXT, $tmp) or die "cannot open $tmp: $!"; 1510 @h = <TEXT>; normalise @h; chomp @h; 1511 close TEXT or die "cannot close $tmp: $!"; 1512 return('list is different when re-read from disk: ' 1513 . Dumper(\@array) . ' vs ' . Dumper(\@h)) 1514 if list_diff(\@array, \@h); 1515 1516 unlink $tmp; 1517 1518 return undef; # success 1519} 1520 1521 1522# list_diff() 1523# 1524# Do two lists differ? 1525# 1526# Parameters: 1527# reference to first list 1528# reference to second list 1529# 1530# Returns true iff they differ. Only works for lists of (string or 1531# undef). 1532# 1533# Surely there is a better way to do this? 1534# 1535sub list_diff { 1536 die 'usage: list_diff(ref to first list, ref to second list)' 1537 if @_ != 2; 1538 my ($a, $b) = @_; 1539 my @a = @$a; my @b = @$b; 1540 return 1 if (scalar @a) != (scalar @b); 1541 for (my $i = 0; $i < @a; $i++) { 1542 my ($ae, $be) = ($a[$i], $b[$i]); 1543 if (defined $ae and defined $be) { 1544 return 1 if $ae ne $be; 1545 } 1546 elsif (not defined $ae and not defined $be) { 1547 # Two undefined values are 'equal' 1548 } 1549 else { 1550 return 1; 1551 } 1552 } 1553 return 0; 1554} 1555 1556 1557# rand_test() 1558# 1559# Think up a random ARRAY, OFFSET, LENGTH, LIST, and context. 1560# ARRAY or LIST might be empty, and OFFSET or LENGTH might be 1561# undefined. Return a 'test' - a listref of these five things. 1562# 1563sub rand_test { 1564 die 'usage: rand_test()' if @_; 1565 my @contexts = qw<list scalar void>; 1566 my $context = $contexts[int(rand @contexts)]; 1567 return [ rand_list(), 1568 (rand() < 0.5) ? (int(rand(20)) - 10) : undef, 1569 (rand() < 0.5) ? (int(rand(20)) - 10) : undef, 1570 rand_list(), 1571 $context ]; 1572} 1573 1574 1575sub rand_list { 1576 die 'usage: rand_list()' if @_; 1577 my @r; 1578 1579 while (rand() > 0.1 * (scalar @r + 1)) { 1580 push @r, rand_word(); 1581 } 1582 return \@r; 1583} 1584 1585 1586sub rand_word { 1587 die 'usage: rand_word()' if @_; 1588 my $r = ''; 1589 my @chars = qw<a b c d e f g h i j k l m n o p q r s t u v w x y z>; 1590 while (rand() > 0.1 * (length($r) + 1)) { 1591 $r .= $chars[int(rand(scalar @chars))]; 1592 } 1593 return $r; 1594} 1595 1596 1597