ext/DB_File/t/db-recno.t

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