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 ;
ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640)
- || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'amigaos') ;
+ || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'cygwin' || $^O eq 'amigaos') ;
#my $l = @h ;
my $l = $X->length ;
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
{
$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.
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") ;
}
{
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" ;
unlink $Dfile;
my $ok = ($x eq "abc-def--ghi-") ;
bad_one() unless $ok ;
- ok(51, $ok) ;
+ ok(61, $ok) ;
}
{
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" ;
unlink $Dfile;
my $ok = ($x eq "abc def ghi ") ;
bad_one() unless $ok ;
- ok(53, $ok) ;
+ ok(63, $ok) ;
}
{
$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" ;
unlink $Dfile;
my $ok = ($x eq "abc--def-------ghi--") ;
bad_one() unless $ok ;
- ok(55, $ok) ;
+ ok(65, $ok) ;
}
{
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 ;
}
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);
# 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;
$_ 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 = $_ }) ;
$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
($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);
($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);
($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;
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 = () ;
$_ = "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;
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;
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
unlink $file ;
}
- ok(126, docat_del($save_output) eq <<'EOM') ;
+ ok(136, docat_del($save_output) eq <<'EOM') ;
ORIGINAL
0: zero
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;
}
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 = <TEXT>; 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<list scalar void>;
+ 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<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>;
+ while (rand() > 0.1 * (length($r) + 1)) {
+ $r .= $chars[int(rand(scalar @chars))];
+ }
+ return $r;
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff