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