X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FDB_File%2Ft%2Fdb-recno.t;h=24ee17c75406703fb3e674195f81aeee2b77081c;hb=13d11c6e852aaac8eff257adcc793baa531c16b1;hp=6dd913cfc2ce6c75cb3b77ad7f80cf5e55bf7b62;hpb=b695f709e8a342e35e482b0437eb6cdacdc58b6b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/DB_File/t/db-recno.t b/ext/DB_File/t/db-recno.t index 6dd913c..24ee17c 100755 --- a/ext/DB_File/t/db-recno.t +++ b/ext/DB_File/t/db-recno.t @@ -1,6 +1,7 @@ #!./perl -w BEGIN { + chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { @@ -100,7 +101,10 @@ sub bad_one EOM } -print "1..128\n"; +my $splice_tests = 10 + 1; # ten regressions, plus the randoms +my $total_tests = 138 ; +$total_tests += $splice_tests if $FA ; +print "1..$total_tests\n"; my $Dfile = "recno.tmp"; unlink $Dfile ; @@ -152,8 +156,8 @@ my $X ; my @h ; ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; -ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640) - || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'amigaos') ; +ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) + || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'cygwin' || $^O eq 'amigaos') ; #my $l = @h ; my $l = $X->length ; @@ -219,7 +223,25 @@ ok(39, $h[6] eq "the") ; ok(40, $h[7] eq "array") ; ok(41, $h[8] eq $data[8]) ; -# SPLICE +# Brief test for SPLICE - more thorough 'soak test' is later. +my @old; +if ($FA) { + @old = splice(@h, 1, 2, qw(bananas just before)); +} +else { + @old = $X->splice(1, 2, qw(bananas just before)); +} +ok(42, $h[0] eq "add") ; +ok(43, $h[1] eq "bananas") ; +ok(44, $h[2] eq "just") ; +ok(45, $h[3] eq "before") ; +ok(46, $h[4] eq "the") ; +ok(47, $h[5] eq "start") ; +ok(48, $h[6] eq "of") ; +ok(49, $h[7] eq "the") ; +ok(50, $h[8] eq "array") ; +ok(51, $h[9] eq $data[8]) ; +$FA ? splice(@h, 1, 3, @old) : $X->splice(1, 3, @old); # Now both arrays should be identical @@ -229,22 +251,22 @@ foreach (@data) { $ok = 0, last if $_ ne $h[$j ++] ; } -ok(42, $ok ); +ok(52, $ok ); # Neagtive subscripts # get the last element of the array -ok(43, $h[-1] eq $data[-1] ); -ok(44, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] ); +ok(53, $h[-1] eq $data[-1] ); +ok(54, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] ); # get the first element using a negative subscript eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ; -ok(45, $@ eq "" ); -ok(46, $h[0] eq "abcd" ); +ok(55, $@ eq "" ); +ok(56, $h[0] eq "abcd" ); # now try to read before the start of the array eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ; -ok(47, $@ =~ '^Modification of non-creatable array value attempted' ); +ok(57, $@ =~ '^Modification of non-creatable array value attempted' ); # IMPORTANT - $X must be undefined before the untie otherwise the # underlying DB close routine will not get called. @@ -259,14 +281,15 @@ unlink $Dfile; my @h = () ; my $dbh = new DB_File::RECNOINFO ; - ok(48, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + ok(58, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; $h[0] = "abc" ; $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; my $x = docat($Dfile) ; unlink $Dfile; - ok(49, $x eq "abc\ndef\n\nghi\n") ; + ok(59, $x eq "abc\ndef\n\nghi\n" || + $x eq "abc\r\ndef\r\n\r\nghi\r\n") ; } { @@ -275,7 +298,7 @@ unlink $Dfile; my @h = () ; my $dbh = new DB_File::RECNOINFO ; $dbh->{bval} = "-" ; - ok(50, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + ok(60, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; $h[0] = "abc" ; $h[1] = "def" ; $h[3] = "ghi" ; @@ -284,7 +307,7 @@ unlink $Dfile; unlink $Dfile; my $ok = ($x eq "abc-def--ghi-") ; bad_one() unless $ok ; - ok(51, $ok) ; + ok(61, $ok) ; } { @@ -294,7 +317,7 @@ unlink $Dfile; my $dbh = new DB_File::RECNOINFO ; $dbh->{flags} = R_FIXEDLEN ; $dbh->{reclen} = 5 ; - ok(52, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + ok(62, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; $h[0] = "abc" ; $h[1] = "def" ; $h[3] = "ghi" ; @@ -303,7 +326,7 @@ unlink $Dfile; unlink $Dfile; my $ok = ($x eq "abc def ghi ") ; bad_one() unless $ok ; - ok(53, $ok) ; + ok(63, $ok) ; } { @@ -314,7 +337,7 @@ unlink $Dfile; $dbh->{flags} = R_FIXEDLEN ; $dbh->{bval} = "-" ; $dbh->{reclen} = 5 ; - ok(54, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + ok(64, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; $h[0] = "abc" ; $h[1] = "def" ; $h[3] = "ghi" ; @@ -323,7 +346,7 @@ unlink $Dfile; unlink $Dfile; my $ok = ($x eq "abc--def-------ghi--") ; bad_one() unless $ok ; - ok(55, $ok) ; + ok(65, $ok) ; } { @@ -332,7 +355,7 @@ unlink $Dfile; my $filename = "xyz" ; my %x ; eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; - ok(56, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; + ok(66, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; unlink $filename ; } @@ -399,31 +422,31 @@ EOM BEGIN { push @INC, '.'; } eval 'use SubDB ; '; - main::ok(57, $@ eq "") ; + main::ok(67, $@ eq "") ; my @h ; my $X ; eval ' $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); ' ; - main::ok(58, $@ eq "") ; + main::ok(68, $@ eq "") ; my $ret = eval '$h[3] = 3 ; return $h[3] ' ; - main::ok(59, $@ eq "") ; - main::ok(60, $ret == 5) ; + main::ok(69, $@ eq "") ; + main::ok(70, $ret == 5) ; my $value = 0; $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; - main::ok(61, $@ eq "") ; - main::ok(62, $ret == 10) ; + main::ok(71, $@ eq "") ; + main::ok(72, $ret == 10) ; $ret = eval ' R_NEXT eq main::R_NEXT ' ; - main::ok(63, $@ eq "" ) ; - main::ok(64, $ret == 1) ; + main::ok(73, $@ eq "" ) ; + main::ok(74, $ret == 1) ; $ret = eval '$X->A_new_method(1) ' ; - main::ok(65, $@ eq "") ; - main::ok(66, $ret eq "[[11]]") ; + main::ok(75, $@ eq "") ; + main::ok(76, $ret eq "[[11]]") ; undef $X; untie(@h); @@ -436,52 +459,52 @@ EOM # test $# my $self ; unlink $Dfile; - ok(67, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; + ok(77, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; $h[0] = "abc" ; $h[1] = "def" ; $h[2] = "ghi" ; $h[3] = "jkl" ; - ok(68, $FA ? $#h == 3 : $self->length() == 4) ; + ok(78, $FA ? $#h == 3 : $self->length() == 4) ; undef $self ; untie @h ; my $x = docat($Dfile) ; - ok(69, $x eq "abc\ndef\nghi\njkl\n") ; + ok(79, $x eq "abc\ndef\nghi\njkl\n") ; # $# sets array to same length - ok(70, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + ok(80, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; if ($FA) { $#h = 3 } else { $self->STORESIZE(4) } - ok(71, $FA ? $#h == 3 : $self->length() == 4) ; + ok(81, $FA ? $#h == 3 : $self->length() == 4) ; undef $self ; untie @h ; $x = docat($Dfile) ; - ok(72, $x eq "abc\ndef\nghi\njkl\n") ; + ok(82, $x eq "abc\ndef\nghi\njkl\n") ; # $# sets array to bigger - ok(73, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + ok(83, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; if ($FA) { $#h = 6 } else { $self->STORESIZE(7) } - ok(74, $FA ? $#h == 6 : $self->length() == 7) ; + ok(84, $FA ? $#h == 6 : $self->length() == 7) ; undef $self ; untie @h ; $x = docat($Dfile) ; - ok(75, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; + ok(85, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; # $# sets array smaller - ok(76, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + ok(86, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; if ($FA) { $#h = 2 } else { $self->STORESIZE(3) } - ok(77, $FA ? $#h == 2 : $self->length() == 3) ; + ok(87, $FA ? $#h == 2 : $self->length() == 3) ; undef $self ; untie @h ; $x = docat($Dfile) ; - ok(78, $x eq "abc\ndef\nghi\n") ; + ok(88, $x eq "abc\ndef\nghi\n") ; unlink $Dfile; @@ -505,7 +528,7 @@ EOM $_ eq 'original' ; } - ok(79, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + ok(89, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); $db->filter_fetch_key (sub { $fetch_key = $_ }) ; $db->filter_store_key (sub { $store_key = $_ }) ; @@ -516,17 +539,17 @@ EOM $h[0] = "joe" ; # fk sk fv sv - ok(80, checkOutput( "", 0, "", "joe")) ; + ok(90, checkOutput( "", 0, "", "joe")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(81, $h[0] eq "joe"); + ok(91, $h[0] eq "joe"); # fk sk fv sv - ok(82, checkOutput( "", 0, "joe", "")) ; + ok(92, checkOutput( "", 0, "joe", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(83, $db->FIRSTKEY() == 0) ; + ok(93, $db->FIRSTKEY() == 0) ; # fk sk fv sv - ok(84, checkOutput( 0, "", "", "")) ; + ok(94, checkOutput( 0, "", "", "")) ; # replace the filters, but remember the previous set my ($old_fk) = $db->filter_fetch_key @@ -541,17 +564,17 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h[1] = "Joe" ; # fk sk fv sv - ok(85, checkOutput( "", 2, "", "Jxe")) ; + ok(95, checkOutput( "", 2, "", "Jxe")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(86, $h[1] eq "[Jxe]"); + ok(96, $h[1] eq "[Jxe]"); # fk sk fv sv - ok(87, checkOutput( "", 2, "[Jxe]", "")) ; + ok(97, checkOutput( "", 2, "[Jxe]", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(88, $db->FIRSTKEY() == 1) ; + ok(98, $db->FIRSTKEY() == 1) ; # fk sk fv sv - ok(89, checkOutput( 1, "", "", "")) ; + ok(99, checkOutput( 1, "", "", "")) ; # put the original filters back $db->filter_fetch_key ($old_fk); @@ -561,15 +584,15 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h[0] = "joe" ; - ok(90, checkOutput( "", 0, "", "joe")) ; + ok(100, checkOutput( "", 0, "", "joe")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(91, $h[0] eq "joe"); - ok(92, checkOutput( "", 0, "joe", "")) ; + ok(101, $h[0] eq "joe"); + ok(102, checkOutput( "", 0, "joe", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(93, $db->FIRSTKEY() == 0) ; - ok(94, checkOutput( 0, "", "", "")) ; + ok(103, $db->FIRSTKEY() == 0) ; + ok(104, checkOutput( 0, "", "", "")) ; # delete the filters $db->filter_fetch_key (undef); @@ -579,15 +602,15 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h[0] = "joe" ; - ok(95, checkOutput( "", "", "", "")) ; + ok(105, checkOutput( "", "", "", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(96, $h[0] eq "joe"); - ok(97, checkOutput( "", "", "", "")) ; + ok(106, $h[0] eq "joe"); + ok(107, checkOutput( "", "", "", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(98, $db->FIRSTKEY() == 0) ; - ok(99, checkOutput( "", "", "", "")) ; + ok(108, $db->FIRSTKEY() == 0) ; + ok(109, checkOutput( "", "", "", "")) ; undef $db ; untie @h; @@ -602,7 +625,7 @@ EOM my (@h, $db) ; unlink $Dfile; - ok(100, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + ok(110, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); my %result = () ; @@ -626,32 +649,32 @@ EOM $_ = "original" ; $h[0] = "joe" ; - ok(101, $result{"store key"} eq "store key - 1: [0]"); - ok(102, $result{"store value"} eq "store value - 1: [joe]"); - ok(103, ! defined $result{"fetch key"} ); - ok(104, ! defined $result{"fetch value"} ); - ok(105, $_ eq "original") ; - - ok(106, $db->FIRSTKEY() == 0 ) ; - ok(107, $result{"store key"} eq "store key - 1: [0]"); - ok(108, $result{"store value"} eq "store value - 1: [joe]"); - ok(109, $result{"fetch key"} eq "fetch key - 1: [0]"); - ok(110, ! defined $result{"fetch value"} ); - ok(111, $_ eq "original") ; + ok(111, $result{"store key"} eq "store key - 1: [0]"); + ok(112, $result{"store value"} eq "store value - 1: [joe]"); + ok(113, ! defined $result{"fetch key"} ); + ok(114, ! defined $result{"fetch value"} ); + ok(115, $_ eq "original") ; + + ok(116, $db->FIRSTKEY() == 0 ) ; + ok(117, $result{"store key"} eq "store key - 1: [0]"); + ok(118, $result{"store value"} eq "store value - 1: [joe]"); + ok(119, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(120, ! defined $result{"fetch value"} ); + ok(121, $_ eq "original") ; $h[7] = "john" ; - ok(112, $result{"store key"} eq "store key - 2: [0 7]"); - ok(113, $result{"store value"} eq "store value - 2: [joe john]"); - ok(114, $result{"fetch key"} eq "fetch key - 1: [0]"); - ok(115, ! defined $result{"fetch value"} ); - ok(116, $_ eq "original") ; - - ok(117, $h[0] eq "joe"); - ok(118, $result{"store key"} eq "store key - 3: [0 7 0]"); - ok(119, $result{"store value"} eq "store value - 2: [joe john]"); - ok(120, $result{"fetch key"} eq "fetch key - 1: [0]"); - ok(121, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(122, $_ eq "original") ; + ok(122, $result{"store key"} eq "store key - 2: [0 7]"); + ok(123, $result{"store value"} eq "store value - 2: [joe john]"); + ok(124, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(125, ! defined $result{"fetch value"} ); + ok(126, $_ eq "original") ; + + ok(127, $h[0] eq "joe"); + ok(128, $result{"store key"} eq "store key - 3: [0 7 0]"); + ok(129, $result{"store value"} eq "store value - 2: [joe john]"); + ok(130, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(131, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(132, $_ eq "original") ; undef $db ; untie @h; @@ -665,12 +688,12 @@ EOM my (@h, $db) ; unlink $Dfile; - ok(123, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + ok(133, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); $db->filter_store_key (sub { $_ = $h[0] }) ; eval '$h[1] = 1234' ; - ok(124, $@ =~ /^recursion detected in filter_store_key at/ ); + ok(134, $@ =~ /^recursion detected in filter_store_key at/ ); undef $db ; untie @h; @@ -728,7 +751,7 @@ EOM unlink $filename ; } - ok(125, docat_del($file) eq <<'EOM') ; + ok(135, docat_del($file) eq <<'EOM') ; The array contains 5 entries popped black shifted white @@ -813,7 +836,7 @@ EOM unlink $file ; } - ok(126, docat_del($save_output) eq <<'EOM') ; + ok(136, docat_del($save_output) eq <<'EOM') ; ORIGINAL 0: zero @@ -861,7 +884,7 @@ EOM tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO or die "Can't open file: $!\n" ; $h[0] = undef; - ok(127, $a eq "") ; + ok(137, $a eq "") ; untie @h ; unlink $Dfile; } @@ -881,9 +904,343 @@ EOM tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO or die "Can't open file: $!\n" ; @h = (); ; - ok(128, $a eq "") ; + ok(138, $a eq "") ; untie @h ; unlink $Dfile; } +# Only test splice if this is a newish version of Perl +exit unless $FA ; + +# Test SPLICE +# +# These are a few regression tests: bundles of five arguments to pass +# to test_splice(). The first four arguments correspond to those +# given to splice(), and the last says which context to call it in +# (scalar, list or void). +# +# The expected result is not needed because we get that by running +# Perl's built-in splice(). +# +my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion', + 'rarely', 'paleness' ], + -4, -2, + [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ], + 'void' ], + + [ [ 'a' ], -2, 1, [ 'B' ], 'void' ], + + [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ], + 0, -4, + [ 'maids' ], + 'void' ], + + [ [ 'visibility', 'pocketful', 'rectangles' ], + -10, 0, + [ 'garbages' ], + 'void' ], + + [ [ 'sleeplessly' ], + 8, -4, + [ 'Margery', 'clearing', 'repercussion', 'clubs', + 'arise' ], + 'void' ], + + [ [ 'chastises', 'recalculates' ], + 0, 0, + [ 'momentariness', 'mediates', 'accents', 'toils', + 'regaled' ], + 'void' ], + + [ [ 'b', '' ], + 9, 8, + [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], + 'scalar' ], + + [ [ 'b', '' ], + undef, undef, + [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], + 'scalar' ], + + [ [ 'riheb' ], -8, undef, [], 'void' ], + + [ [ 'uft', 'qnxs', '' ], + 6, -2, + [ 'znp', 'mhnkh', 'bn' ], + 'void' ], + ); + +my $testnum = 139; +my $failed = 0; +require POSIX; my $tmp = POSIX::tmpnam(); +foreach my $test (@tests) { + my $err = test_splice(@$test); + if (defined $err) { + require Data::Dumper; + print STDERR "failed: ", Data::Dumper::Dumper($test); + print STDERR "error: $err\n"; + $failed = 1; + ok($testnum++, 0); + } + else { ok($testnum++, 1) } +} + +if ($failed) { + # Not worth running the random ones + print STDERR 'skipping ', $testnum++, "\n"; +} +else { + # A thousand randomly-generated tests + $failed = 0; + srand(0); + foreach (0 .. 1000 - 1) { + my $test = rand_test(); + my $err = test_splice(@$test); + if (defined $err) { + require Data::Dumper; + print STDERR "failed: ", Data::Dumper::Dumper($test); + print STDERR "error: $err\n"; + $failed = 1; + print STDERR "skipping any remaining random tests\n"; + last; + } + } + + ok($testnum++, not $failed); +} + +die if $testnum != $total_tests + 1; + exit ; + +# Subroutines for SPLICE testing + +# test_splice() +# +# Test the new splice() against Perl's built-in one. The first four +# parameters are those passed to splice(), except that the lists must +# be (explicitly) passed by reference, and are not actually modified. +# (It's just a test!) The last argument specifies the context in +# which to call the functions: 'list', 'scalar', or 'void'. +# +# Returns: +# undef, if the two splices give the same results for the given +# arguments and context; +# +# an error message showing the difference, otherwise. +# +# Reads global variable $tmp. +# +sub test_splice { + die 'usage: test_splice(array, offset, length, list, context)' if @_ != 5; + my ($array, $offset, $length, $list, $context) = @_; + my @array = @$array; + my @list = @$list; + + open(TEXT, ">$tmp") or die "cannot write to $tmp: $!"; + foreach (@array) { print TEXT "$_\n" } + close TEXT or die "cannot close $tmp: $!"; + + my @h; + my $H = tie @h, 'DB_File', $tmp, O_RDWR, 0644, $DB_RECNO + or die "cannot open $tmp: $!"; + + return "basic DB_File sanity check failed" + if list_diff(\@array, \@h); + + # Output from splice(): + # Returned value (munged a bit), error msg, warnings + # + my ($s_r, $s_error, @s_warnings); + + my $gather_warning = sub { push @s_warnings, $_[0] }; + if ($context eq 'list') { + my @r; + eval { + local $SIG{__WARN__} = $gather_warning; + @r = splice @array, $offset, $length, @list; + }; + $s_error = $@; + $s_r = \@r; + } + elsif ($context eq 'scalar') { + my $r; + eval { + local $SIG{__WARN__} = $gather_warning; + $r = splice @array, $offset, $length, @list; + }; + $s_error = $@; + $s_r = [ $r ]; + } + elsif ($context eq 'void') { + eval { + local $SIG{__WARN__} = $gather_warning; + splice @array, $offset, $length, @list; + }; + $s_error = $@; + $s_r = []; + } + else { + die "bad context $context"; + } + + foreach ($s_error, @s_warnings) { + chomp; + s/ at \S+ line \d+\.$//; + } + + # Now do the same for DB_File's version of splice + my ($ms_r, $ms_error, @ms_warnings); + $gather_warning = sub { push @ms_warnings, $_[0] }; + if ($context eq 'list') { + my @r; + eval { + local $SIG{__WARN__} = $gather_warning; + @r = splice @h, $offset, $length, @list; + }; + $ms_error = $@; + $ms_r = \@r; + } + elsif ($context eq 'scalar') { + my $r; + eval { + local $SIG{__WARN__} = $gather_warning; + $r = splice @h, $offset, $length, @list; + }; + $ms_error = $@; + $ms_r = [ $r ]; + } + elsif ($context eq 'void') { + eval { + local $SIG{__WARN__} = $gather_warning; + splice @h, $offset, $length, @list; + }; + $ms_error = $@; + $ms_r = []; + } + else { + die "bad context $context"; + } + + foreach ($ms_error, @ms_warnings) { + chomp; + s/ at \S+ line \d+\.?$//; + } + + return "different errors: '$s_error' vs '$ms_error'" + if $s_error ne $ms_error; + return('different return values: ' . Dumper($s_r) . ' vs ' . Dumper($ms_r)) + if list_diff($s_r, $ms_r); + return('different changed list: ' . Dumper(\@array) . ' vs ' . Dumper(\@h)) + if list_diff(\@array, \@h); + + if ((scalar @s_warnings) != (scalar @ms_warnings)) { + return 'different number of warnings'; + } + + while (@s_warnings) { + my $sw = shift @s_warnings; + my $msw = shift @ms_warnings; + + if (defined $sw and defined $msw) { + $msw =~ s/ \(.+\)$//; + $msw =~ s/ in splice$// if $] < 5.006; + if ($sw ne $msw) { + return "different warning: '$sw' vs '$msw'"; + } + } + elsif (not defined $sw and not defined $msw) { + # Okay. + } + else { + return "one warning defined, another undef"; + } + } + + undef $H; + untie @h; + + open(TEXT, $tmp) or die "cannot open $tmp: $!"; + @h = ; chomp @h; + close TEXT or die "cannot close $tmp: $!"; + return('list is different when re-read from disk: ' + . Dumper(\@array) . ' vs ' . Dumper(\@h)) + if list_diff(\@array, \@h); + + return undef; # success +} + + +# list_diff() +# +# Do two lists differ? +# +# Parameters: +# reference to first list +# reference to second list +# +# Returns true iff they differ. Only works for lists of (string or +# undef). +# +# Surely there is a better way to do this? +# +sub list_diff { + die 'usage: list_diff(ref to first list, ref to second list)' + if @_ != 2; + my ($a, $b) = @_; + my @a = @$a; my @b = @$b; + return 1 if (scalar @a) != (scalar @b); + for (my $i = 0; $i < @a; $i++) { + my ($ae, $be) = ($a[$i], $b[$i]); + if (defined $ae and defined $be) { + return 1 if $ae ne $be; + } + elsif (not defined $ae and not defined $be) { + # Two undefined values are 'equal' + } + else { + return 1; + } + } + return 0; +} + + +# rand_test() +# +# Think up a random ARRAY, OFFSET, LENGTH, LIST, and context. +# ARRAY or LIST might be empty, and OFFSET or LENGTH might be +# undefined. Return a 'test' - a listref of these five things. +# +sub rand_test { + die 'usage: rand_test()' if @_; + my @contexts = qw; + my $context = $contexts[int(rand @contexts)]; + return [ rand_list(), + (rand() < 0.5) ? (int(rand(20)) - 10) : undef, + (rand() < 0.5) ? (int(rand(20)) - 10) : undef, + rand_list(), + $context ]; +} + + +sub rand_list { + die 'usage: rand_list()' if @_; + my @r; + + while (rand() > 0.1 * (scalar @r + 1)) { + push @r, rand_word(); + } + return \@r; +} + + +sub rand_word { + die 'usage: rand_word()' if @_; + my $r = ''; + my @chars = qw; + while (rand() > 0.1 * (length($r) + 1)) { + $r .= $chars[int(rand(scalar @chars))]; + } + return $r; +}