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     $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ;
 526     ok(87, $self)
 527         or warn "# $DB_File::Error\n";
 528     if ($FA)
 529       { $#h = 3 }
 530     else
 531       { $self->STORESIZE(4) }
 532     ok(88, $FA ? $#h == 3 : $self->length() == 4) ;
 533     undef $self ;
 534     ok(89, safeUntie \@h);
 535     $x = docat($Dfile) ;
 536     ok(90, $x eq "abc\ndef\nghi\njkl\n") ;
 537
 538     # $# sets array to bigger
 539     ok(91, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
 540     if ($FA)
 541       { $#h = 6 }
 542     else
 543       { $self->STORESIZE(7) }
 544     ok(92, $FA ? $#h == 6 : $self->length() == 7) ;
 545     undef $self ;
 546     ok(93, safeUntie \@h);
 547     $x = docat($Dfile) ;
 548     ok(94, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ;
 549
 550     # $# sets array smaller
 551     ok(95, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
 552     if ($FA)
 553       { $#h = 2 }
 554     else
 555       { $self->STORESIZE(3) }
 556     ok(96, $FA ? $#h == 2 : $self->length() == 3) ;
 557     undef $self ;
 558     ok(97, safeUntie \@h);
 559     $x = docat($Dfile) ;
 560     ok(98, $x eq "abc\ndef\nghi\n") ;
 561
 562     unlink $Dfile;
 563
 564
 565 }
 566
 567 {
 568    # DBM Filter tests
 569    use warnings ;
 570    use strict ;
 571    my (@h, $db) ;
 572    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 573    unlink $Dfile;
 574
 575    sub checkOutput
 576    {
 577        my($fk, $sk, $fv, $sv) = @_ ;
 578
 579        print "# Fetch Key   : expected '$fk' got '$fetch_key'\n"
 580            if $fetch_key ne $fk ;
 581        print "# Fetch Value : expected '$fv' got '$fetch_value'\n"
 582            if $fetch_value ne $fv ;
 583        print "# Store Key   : expected '$sk' got '$store_key'\n"
 584            if $store_key ne $sk ;
 585        print "# Store Value : expected '$sv' got '$store_value'\n"
 586            if $store_value ne $sv ;
 587        print "# \$_          : expected 'original' got '$_'\n"
 588            if $_ ne 'original' ;
 589
 590        return
 591            $fetch_key   eq $fk && $store_key   eq $sk &&
 592            $fetch_value eq $fv && $store_value eq $sv &&
 593            $_ eq 'original' ;
 594    }
 595
 596    ok(99, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
 597
 598    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
 599    $db->filter_store_key   (sub { $store_key = $_ }) ;
 600    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
 601    $db->filter_store_value (sub { $store_value = $_ }) ;
 602
 603    $_ = "original" ;
 604
 605    $h[0] = "joe" ;
 606    #                   fk   sk     fv   sv
 607    ok(100, checkOutput( "", 0, "", "joe")) ;
 608
 609    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 610    ok(101, $h[0] eq "joe");
 611    #                   fk  sk  fv    sv
 612    ok(102, checkOutput( "", 0, "joe", "")) ;
 613
 614    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 615    ok(103, $db->FIRSTKEY() == 0) ;
 616    #                    fk     sk  fv  sv
 617    ok(104, checkOutput( 0, "", "", "")) ;
 618
 619    # replace the filters, but remember the previous set
 620    my ($old_fk) = $db->filter_fetch_key
 621                         (sub { ++ $_ ; $fetch_key = $_ }) ;
 622    my ($old_sk) = $db->filter_store_key
 623                         (sub { $_ *= 2 ; $store_key = $_ }) ;
 624    my ($old_fv) = $db->filter_fetch_value
 625                         (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
 626    my ($old_sv) = $db->filter_store_value
 627                         (sub { s/o/x/g; $store_value = $_ }) ;
 628
 629    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 630    $h[1] = "Joe" ;
 631    #                   fk   sk     fv    sv
 632    ok(105, checkOutput( "", 2, "", "Jxe")) ;
 633
 634    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 635    ok(106, $h[1] eq "[Jxe]");
 636    #                   fk   sk     fv    sv
 637    ok(107, checkOutput( "", 2, "[Jxe]", "")) ;
 638
 639    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 640    ok(108, $db->FIRSTKEY() == 1) ;
 641    #                   fk   sk     fv    sv
 642    ok(109, checkOutput( 1, "", "", "")) ;
 643
 644    # put the original filters back
 645    $db->filter_fetch_key   ($old_fk);
 646    $db->filter_store_key   ($old_sk);
 647    $db->filter_fetch_value ($old_fv);
 648    $db->filter_store_value ($old_sv);
 649
 650    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 651    $h[0] = "joe" ;
 652    ok(110, checkOutput( "", 0, "", "joe")) ;
 653
 654    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 655    ok(111, $h[0] eq "joe");
 656    ok(112, checkOutput( "", 0, "joe", "")) ;
 657
 658    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 659    ok(113, $db->FIRSTKEY() == 0) ;
 660    ok(114, checkOutput( 0, "", "", "")) ;
 661
 662    # delete the filters
 663    $db->filter_fetch_key   (undef);
 664    $db->filter_store_key   (undef);
 665    $db->filter_fetch_value (undef);
 666    $db->filter_store_value (undef);
 667
 668    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 669    $h[0] = "joe" ;
 670    ok(115, checkOutput( "", "", "", "")) ;
 671
 672    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 673    ok(116, $h[0] eq "joe");
 674    ok(117, checkOutput( "", "", "", "")) ;
 675
 676    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 677    ok(118, $db->FIRSTKEY() == 0) ;
 678    ok(119, checkOutput( "", "", "", "")) ;
 679
 680    undef $db ;
 681    ok(120, safeUntie \@h);
 682    unlink $Dfile;
 683 }
 684
 685 {
 686     # DBM Filter with a closure
 687
 688     use warnings ;
 689     use strict ;
 690     my (@h, $db) ;
 691
 692     unlink $Dfile;
 693     ok(121, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
 694
 695     my %result = () ;
 696
 697     sub Closure
 698     {
 699         my ($name) = @_ ;
 700         my $count = 0 ;
 701         my @kept = () ;
 702
 703         return sub { ++$count ;
 704                      push @kept, $_ ;
 705                      $result{$name} = "$name - $count: [@kept]" ;
 706                    }
 707     }
 708
 709     $db->filter_store_key(Closure("store key")) ;
 710     $db->filter_store_value(Closure("store value")) ;
 711     $db->filter_fetch_key(Closure("fetch key")) ;
 712     $db->filter_fetch_value(Closure("fetch value")) ;
 713
 714     $_ = "original" ;
 715
 716     $h[0] = "joe" ;
 717     ok(122, $result{"store key"} eq "store key - 1: [0]");
 718     ok(123, $result{"store value"} eq "store value - 1: [joe]");
 719     ok(124, ! defined $result{"fetch key"} );
 720     ok(125, ! defined $result{"fetch value"} );
 721     ok(126, $_ eq "original") ;
 722
 723     ok(127, $db->FIRSTKEY() == 0 ) ;
 724     ok(128, $result{"store key"} eq "store key - 1: [0]");
 725     ok(129, $result{"store value"} eq "store value - 1: [joe]");
 726     ok(130, $result{"fetch key"} eq "fetch key - 1: [0]");
 727     ok(131, ! defined $result{"fetch value"} );
 728     ok(132, $_ eq "original") ;
 729
 730     $h[7]  = "john" ;
 731     ok(133, $result{"store key"} eq "store key - 2: [0 7]");
 732     ok(134, $result{"store value"} eq "store value - 2: [joe john]");
 733     ok(135, $result{"fetch key"} eq "fetch key - 1: [0]");
 734     ok(136, ! defined $result{"fetch value"} );
 735     ok(137, $_ eq "original") ;
 736
 737     ok(138, $h[0] eq "joe");
 738     ok(139, $result{"store key"} eq "store key - 3: [0 7 0]");
 739     ok(140, $result{"store value"} eq "store value - 2: [joe john]");
 740     ok(141, $result{"fetch key"} eq "fetch key - 1: [0]");
 741     ok(142, $result{"fetch value"} eq "fetch value - 1: [joe]");
 742     ok(143, $_ eq "original") ;
 743
 744     undef $db ;
 745     ok(144, safeUntie \@h);
 746     unlink $Dfile;
 747 }
 748
 749 {
 750    # DBM Filter recursion detection
 751    use warnings ;
 752    use strict ;
 753    my (@h, $db) ;
 754    unlink $Dfile;
 755
 756    ok(145, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
 757
 758    $db->filter_store_key (sub { $_ = $h[0] }) ;
 759
 760    eval '$h[1] = 1234' ;
 761    ok(146, $@ =~ /^recursion detected in filter_store_key at/ );
 762
 763    undef $db ;
 764    ok(147, safeUntie \@h);
 765    unlink $Dfile;
 766 }
 767
 768
 769 {
 770    # Examples from the POD
 771
 772   my $file = "xyzt" ;
 773   {
 774     my $redirect = new Redirect $file ;
 775
 776     use warnings FATAL => qw(all);
 777     use strict ;
 778     use DB_File ;
 779
 780     my $filename = "text" ;
 781     unlink $filename ;
 782
 783     my @h ;
 784     my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO
 785         or die "Cannot open file 'text': $!\n" ;
 786
 787     # Add a few key/value pairs to the file
 788     $h[0] = "orange" ;
 789     $h[1] = "blue" ;
 790     $h[2] = "yellow" ;
 791
 792     $FA ? push @h, "green", "black"
 793         : $x->push("green", "black") ;
 794
 795     my $elements = $FA ? scalar @h : $x->length ;
 796     print "The array contains $elements entries\n" ;
 797
 798     my $last = $FA ? pop @h : $x->pop ;
 799     print "popped $last\n" ;
 800
 801     $FA ? unshift @h, "white"
 802         : $x->unshift("white") ;
 803     my $first = $FA ? shift @h : $x->shift ;
 804     print "shifted $first\n" ;
 805
 806     # Check for existence of a key
 807     print "Element 1 Exists with value $h[1]\n" if $h[1] ;
 808
 809     # use a negative index
 810     print "The last element is $h[-1]\n" ;
 811     print "The 2nd last element is $h[-2]\n" ;
 812
 813     undef $x ;
 814     untie @h ;
 815
 816     unlink $filename ;
 817   }
 818
 819   ok(148, docat_del($file) eq <<'EOM') ;
 820 The array contains 5 entries
 821 popped black
 822 shifted white
 823 Element 1 Exists with value blue
 824 The last element is green
 825 The 2nd last element is yellow
 826 EOM
 827
 828   my $save_output = "xyzt" ;
 829   {
 830     my $redirect = new Redirect $save_output ;
 831
 832     use warnings FATAL => qw(all);
 833     use strict ;
 834     our (@h, $H, $file, $i);
 835     use DB_File ;
 836     use Fcntl ;
 837
 838     $file = "text" ;
 839
 840     unlink $file ;
 841
 842     $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO
 843         or die "Cannot open file $file: $!\n" ;
 844
 845     # first create a text file to play with
 846     $h[0] = "zero" ;
 847     $h[1] = "one" ;
 848     $h[2] = "two" ;
 849     $h[3] = "three" ;
 850     $h[4] = "four" ;
 851
 852
 853     # Print the records in order.
 854     #
 855     # The length method is needed here because evaluating a tied
 856     # array in a scalar context does not return the number of
 857     # elements in the array.
 858
 859     print "\nORIGINAL\n" ;
 860     foreach $i (0 .. $H->length - 1) {
 861         print "$i: $h[$i]\n" ;
 862     }
 863
 864     # use the push & pop methods
 865     $a = $H->pop ;
 866     $H->push("last") ;
 867     print "\nThe last record was [$a]\n" ;
 868
 869     # and the shift & unshift methods
 870     $a = $H->shift ;
 871     $H->unshift("first") ;
 872     print "The first record was [$a]\n" ;
 873
 874     # Use the API to add a new record after record 2.
 875     $i = 2 ;
 876     $H->put($i, "Newbie", R_IAFTER) ;
 877
 878     # and a new record before record 1.
 879     $i = 1 ;
 880     $H->put($i, "New One", R_IBEFORE) ;
 881
 882     # delete record 3
 883     $H->del(3) ;
 884
 885     # now print the records in reverse order
 886     print "\nREVERSE\n" ;
 887     for ($i = $H->length - 1 ; $i >= 0 ; -- $i)
 888       { print "$i: $h[$i]\n" }
 889
 890     # same again, but use the API functions instead
 891     print "\nREVERSE again\n" ;
 892     my ($s, $k, $v)  = (0, 0, 0) ;
 893     for ($s = $H->seq($k, $v, R_LAST) ;
 894              $s == 0 ;
 895              $s = $H->seq($k, $v, R_PREV))
 896       { print "$k: $v\n" }
 897
 898     undef $H ;
 899     untie @h ;
 900
 901     unlink $file ;
 902   }
 903
 904   ok(149, docat_del($save_output) eq <<'EOM') ;
 905
 906 ORIGINAL
 907 0: zero
 908 1: one
 909 2: two
 910 3: three
 911 4: four
 912
 913 The last record was [four]
 914 The first record was [zero]
 915
 916 REVERSE
 917 5: last
 918 4: three
 919 3: Newbie
 920 2: one
 921 1: New One
 922 0: first
 923
 924 REVERSE again
 925 5: last
 926 4: three
 927 3: Newbie
 928 2: one
 929 1: New One
 930 0: first
 931 EOM
 932
 933 }
 934
 935 {
 936     # Bug ID 20001013.009
 937     #
 938     # test that $hash{KEY} = undef doesn't produce the warning
 939     #     Use of uninitialized value in null operation
 940     use warnings ;
 941     use strict ;
 942     use DB_File ;
 943
 944     unlink $Dfile;
 945     my @h ;
 946     my $a = "";
 947     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 948
 949     tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO
 950         or die "Can't open file: $!\n" ;
 951     $h[0] = undef;
 952     ok(150, $a eq "") ;
 953     ok(151, safeUntie \@h);
 954     unlink $Dfile;
 955 }
 956
 957 {
 958     # test that %hash = () doesn't produce the warning
 959     #     Argument "" isn't numeric in entersub
 960     use warnings ;
 961     use strict ;
 962     use DB_File ;
 963     my $a = "";
 964     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 965
 966     unlink $Dfile;
 967     my @h ;
 968
 969     tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO
 970         or die "Can't open file: $!\n" ;
 971     @h = (); ;
 972     ok(152, $a eq "") ;
 973     ok(153, safeUntie \@h);
 974     unlink $Dfile;
 975 }
 976
 977 {
 978    # Check that DBM Filter can cope with read-only $_
 979
 980    use warnings ;
 981    use strict ;
 982    my (@h, $db) ;
 983    unlink $Dfile;
 984
 985    ok(154, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
 986
 987    $db->filter_fetch_key   (sub { }) ;
 988    $db->filter_store_key   (sub { }) ;
 989    $db->filter_fetch_value (sub { }) ;
 990    $db->filter_store_value (sub { }) ;
 991
 992    $_ = "original" ;
 993
 994    $h[0] = "joe" ;
 995    ok(155, $h[0] eq "joe");
 996
 997    eval { grep { $h[$_] } (1, 2, 3) };
 998    ok (156, ! $@);
 999
1000
1001    # delete the filters
1002    $db->filter_fetch_key   (undef);
1003    $db->filter_store_key   (undef);
1004    $db->filter_fetch_value (undef);
1005    $db->filter_store_value (undef);
1006
1007    $h[1] = "joe" ;
1008
1009    ok(157, $h[1] eq "joe");
1010
1011    eval { grep { $h[$_] } (1, 2, 3) };
1012    ok (158, ! $@);
1013
1014    undef $db ;
1015    untie @h;
1016    unlink $Dfile;
1017 }
1018
1019 {
1020    # Check low-level API works with filter
1021
1022    use warnings ;
1023    use strict ;
1024    my (@h, $db) ;
1025    my $Dfile = "xxy.db";
1026    unlink $Dfile;
1027
1028    ok(159, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
1029
1030
1031    $db->filter_fetch_key   (sub { ++ $_ } );
1032    $db->filter_store_key   (sub { -- $_ } );
1033    $db->filter_fetch_value (sub { $_ = unpack("i", $_) } );
1034    $db->filter_store_value (sub { $_ = pack("i", $_) } );
1035
1036    $_ = 'fred';
1037
1038    my $key = 22 ;
1039    my $value = 34 ;
1040
1041    $db->put($key, $value) ;
1042    ok 160, $key == 22;
1043    ok 161, $value == 34 ;
1044    ok 162, $_ eq 'fred';
1045    #print "k [$key][$value]\n" ;
1046
1047    my $val ;
1048    $db->get($key, $val) ;
1049    ok 163, $key == 22;
1050    ok 164, $val == 34 ;
1051    ok 165, $_ eq 'fred';
1052
1053    $key = 51 ;
1054    $value = 454;
1055    $h[$key] = $value ;
1056    ok 166, $key == 51;
1057    ok 167, $value == 454 ;
1058    ok 168, $_ eq 'fred';
1059
1060    undef $db ;
1061    untie @h;
1062    unlink $Dfile;
1063 }
1064
1065
1066 {
1067     # Regression Test for bug 30237
1068     # Check that substr can be used in the key to db_put
1069     # and that db_put does not trigger the warning
1070     #
1071     #     Use of uninitialized value in subroutine entry
1072
1073
1074     use warnings ;
1075     use strict ;
1076     my (@h, $db) ;
1077     my $status ;
1078     my $Dfile = "xxy.db";
1079     unlink $Dfile;
1080
1081     ok(169, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO) );
1082
1083     my $warned = '';
1084     local $SIG{__WARN__} = sub {$warned = $_[0]} ;
1085
1086     # db-put with substr of key
1087     my %remember = () ;
1088     for my $ix ( 0 .. 2 )
1089     {
1090         my $key = $ix . "data" ;
1091         my $value = "value$ix" ;
1092         $remember{substr($key,0, 1)} = $value ;
1093         $db->put(substr($key,0, 1), $value) ;
1094     }
1095
1096     ok 170, $warned eq ''
1097       or print "# Caught warning [$warned]\n" ;
1098
1099     # db-put with substr of value
1100     $warned = '';
1101     for my $ix ( 3 .. 5 )
1102     {
1103         my $key = $ix . "data" ;
1104         my $value = "value$ix" ;
1105         $remember{$ix} = $value ;
1106         $db->put($ix, substr($value,0)) ;
1107     }
1108
1109     ok 171, $warned eq ''
1110       or print "# Caught warning [$warned]\n" ;
1111
1112     # via the tied array is not a problem, but check anyway
1113     # substr of key
1114     $warned = '';
1115     for my $ix ( 6 .. 8 )
1116     {
1117         my $key = $ix . "data" ;
1118         my $value = "value$ix" ;
1119         $remember{substr($key,0,1)} = $value ;
1120         $h[substr($key,0,1)] = $value ;
1121     }
1122
1123     ok 172, $warned eq ''
1124       or print "# Caught warning [$warned]\n" ;
1125
1126     # via the tied array is not a problem, but check anyway
1127     # substr of value
1128     $warned = '';
1129     for my $ix ( 9 .. 10 )
1130     {
1131         my $key = $ix . "data" ;
1132         my $value = "value$ix" ;
1133         $remember{$ix} = $value ;
1134         $h[$ix] = substr($value,0) ;
1135     }
1136
1137     ok 173, $warned eq ''
1138       or print "# Caught warning [$warned]\n" ;
1139
1140     my %bad = () ;
1141     my $key = '';
1142     for (my $status = $db->seq($key, $value, R_FIRST ) ;
1143          $status == 0 ;
1144          $status = $db->seq($key, $value, R_NEXT ) ) {
1145
1146         #print "# key [$key] value [$value]\n" ;
1147         if (defined $remember{$key} && defined $value &&
1148              $remember{$key} eq $value) {
1149             delete $remember{$key} ;
1150         }
1151         else {
1152             $bad{$key} = $value ;
1153         }
1154     }
1155
1156     ok 174, keys %bad == 0 ;
1157     ok 175, keys %remember == 0 ;
1158
1159     print "# missing -- $key $value\n" while ($key, $value) = each %remember;
1160     print "# bad     -- $key $value\n" while ($key, $value) = each %bad;
1161
1162     # Make sure this fix does not break code to handle an undef key
1163     my $value = 'fred';
1164     $warned = '';
1165     $status = $db->put(undef, $value) ;
1166     ok 176, $status == 0
1167       or print "# put failed - status $status\n";
1168     ok 177, $warned eq ''
1169       or print "# Caught warning [$warned]\n" ;
1170     $warned = '';
1171
1172     print "# db_ver $DB_File::db_ver\n";
1173     $value = '' ;
1174     $status = $db->get(undef, $value) ;
1175     ok 178, $status == 0
1176         or print "# get failed - status $status\n" ;
1177     ok(179, $db->get(undef, $value) == 0) or print "# get failed\n" ;
1178     ok 180, $value eq 'fred' or print "# got [$value]\n" ;
1179     ok 181, $warned eq ''
1180       or print "# Caught warning [$warned]\n" ;
1181     $warned = '';
1182
1183     undef $db ;
1184     untie @h;
1185     unlink $Dfile;
1186 }
1187
1188 # Only test splice if this is a newish version of Perl
1189 exit unless $FA ;
1190
1191 # Test SPLICE
1192
1193 {
1194     # check that the splice warnings are under the same lexical control
1195     # as their non-tied counterparts.
1196
1197     use warnings;
1198     use strict;
1199
1200     my $a = '';
1201     my @a = (1);
1202     local $SIG{__WARN__} = sub {$a = $_[0]} ;
1203
1204     unlink $Dfile;
1205     my @tied ;
1206
1207     tie @tied, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO
1208         or die "Can't open file: $!\n" ;
1209
1210     # uninitialized offset
1211     use warnings;
1212     my $offset ;
1213     $a = '';
1214     splice(@a, $offset);
1215     ok(182, $a =~ /^Use of uninitialized value /);
1216     $a = '';
1217     splice(@tied, $offset);
1218     ok(183, $a =~ /^Use of uninitialized value in splice/);
1219
1220     no warnings 'uninitialized';
1221     $a = '';
1222     splice(@a, $offset);
1223     ok(184, $a eq '');
1224     $a = '';
1225     splice(@tied, $offset);
1226     ok(185, $a eq '');
1227
1228     # uninitialized length
1229     use warnings;
1230     my $length ;
1231     $a = '';
1232     splice(@a, 0, $length);
1233     ok(186, $a =~ /^Use of uninitialized value /);
1234     $a = '';
1235     splice(@tied, 0, $length);
1236     ok(187, $a =~ /^Use of uninitialized value in splice/);
1237
1238     no warnings 'uninitialized';
1239     $a = '';
1240     splice(@a, 0, $length);
1241     ok(188, $a eq '');
1242     $a = '';
1243     splice(@tied, 0, $length);
1244     ok(189, $a eq '');
1245
1246     # offset past end of array
1247     use warnings;
1248     $a = '';
1249     splice(@a, 3);
1250     my $splice_end_array = ($a =~ /^splice\(\) offset past end of array/);
1251     $a = '';
1252     splice(@tied, 3);
1253     ok(190, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/);
1254
1255     no warnings 'misc';
1256     $a = '';
1257     splice(@a, 3);
1258     ok(191, $a eq '');
1259     $a = '';
1260     splice(@tied, 3);
1261     ok(192, $a eq '');
1262
1263     ok(193, safeUntie \@tied);
1264     unlink $Dfile;
1265 }
1266
1267 #
1268 # These are a few regression tests: bundles of five arguments to pass
1269 # to test_splice().  The first four arguments correspond to those
1270 # given to splice(), and the last says which context to call it in
1271 # (scalar, list or void).
1272 #
1273 # The expected result is not needed because we get that by running
1274 # Perl's built-in splice().
1275 #
1276 my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion',
1277                  'rarely', 'paleness' ],
1278                -4, -2,
1279                [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ],
1280                'void' ],
1281
1282              [ [ 'a' ], -2, 1, [ 'B' ], 'void' ],
1283
1284              [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ],
1285                0, -4,
1286                [ 'maids' ],
1287                'void' ],
1288
1289              [ [ 'visibility', 'pocketful', 'rectangles' ],
1290                -10, 0,
1291                [ 'garbages' ],
1292                'void' ],
1293
1294              [ [ 'sleeplessly' ],
1295                8, -4,
1296                [ 'Margery', 'clearing', 'repercussion', 'clubs',
1297                  'arise' ],
1298                'void' ],
1299
1300              [ [ 'chastises', 'recalculates' ],
1301                0, 0,
1302                [ 'momentariness', 'mediates', 'accents', 'toils',
1303                  'regaled' ],
1304                'void' ],
1305
1306              [ [ 'b', '' ],
1307                9, 8,
1308                [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
1309                'scalar' ],
1310
1311              [ [ 'b', '' ],
1312                undef, undef,
1313                [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
1314                'scalar' ],
1315
1316              [ [ 'riheb' ], -8, undef, [], 'void' ],
1317
1318              [ [ 'uft', 'qnxs', '' ],
1319                6, -2,
1320                [ 'znp', 'mhnkh', 'bn' ],
1321                'void' ],
1322             );
1323
1324 my $testnum = 194;
1325 my $failed = 0;
1326 my $tmp = "dbr$$";
1327 foreach my $test (@tests) {
1328     my $err = test_splice(@$test);
1329     if (defined $err) {
1330         print STDERR "# failed: ", Dumper($test);
1331         print STDERR "# error: $err\n";
1332         $failed = 1;
1333         ok($testnum++, 0);
1334     }
1335     else { ok($testnum++, 1) }
1336 }
1337
1338 if ($failed) {
1339     # Not worth running the random ones
1340     print STDERR '# skipping ', $testnum++, "\n";
1341 }
1342 else {
1343     # A thousand randomly-generated tests
1344     $failed = 0;
1345     srand(0);
1346     foreach (0 .. 1000 - 1) {
1347         my $test = rand_test();
1348         my $err = test_splice(@$test);
1349         if (defined $err) {
1350             print STDERR "# failed: ", Dumper($test);
1351             print STDERR "# error: $err\n";
1352             $failed = 1;
1353             print STDERR "# skipping any remaining random tests\n";
1354             last;
1355         }
1356     }
1357
1358     ok($testnum++, not $failed);
1359 }
1360
1361 die "testnum ($testnum) != total_tests ($total_tests) + 1"
1362     if $testnum != $total_tests + 1;
1363
1364 exit ;
1365
1366 # Subroutines for SPLICE testing
1367
1368 # test_splice()
1369 #
1370 # Test the new splice() against Perl's built-in one.  The first four
1371 # parameters are those passed to splice(), except that the lists must
1372 # be (explicitly) passed by reference, and are not actually modified.
1373 # (It's just a test!)  The last argument specifies the context in
1374 # which to call the functions: 'list', 'scalar', or 'void'.
1375 #
1376 # Returns:
1377 #   undef, if the two splices give the same results for the given
1378 #     arguments and context;
1379 #
1380 #   an error message showing the difference, otherwise.
1381 #
1382 # Reads global variable $tmp.
1383 #
1384 sub test_splice {
1385     die 'usage: test_splice(array, offset, length, list, context)' if @_ != 5;
1386     my ($array, $offset, $length, $list, $context) = @_;
1387     my @array = @$array;
1388     my @list = @$list;
1389
1390     unlink $tmp;
1391
1392     my @h;
1393     my $H = tie @h, 'DB_File', $tmp, O_CREAT|O_RDWR, 0644, $DB_RECNO
1394       or die "cannot open $tmp: $!";
1395
1396     my $i = 0;
1397     foreach ( @array ) { $h[$i++] = $_ }
1398
1399     return "basic DB_File sanity check failed"
1400       if list_diff(\@array, \@h);
1401
1402     # Output from splice():
1403     # Returned value (munged a bit), error msg, warnings
1404     #
1405     my ($s_r, $s_error, @s_warnings);
1406
1407     my $gather_warning = sub { push @s_warnings, $_[0] };
1408     if ($context eq 'list') {
1409         my @r;
1410         eval {
1411             local $SIG{__WARN__} = $gather_warning;
1412             @r = splice @array, $offset, $length, @list;
1413         };
1414         $s_error = $@;
1415         $s_r = \@r;
1416     }
1417     elsif ($context eq 'scalar') {
1418         my $r;
1419         eval {
1420             local $SIG{__WARN__} = $gather_warning;
1421             $r = splice @array, $offset, $length, @list;
1422         };
1423         $s_error = $@;
1424         $s_r = [ $r ];
1425     }
1426     elsif ($context eq 'void') {
1427         eval {
1428             local $SIG{__WARN__} = $gather_warning;
1429             splice @array, $offset, $length, @list;
1430         };
1431         $s_error = $@;
1432         $s_r = [];
1433     }
1434     else {
1435         die "bad context $context";
1436     }
1437
1438     foreach ($s_error, @s_warnings) {
1439         chomp;
1440         s/ at \S+ line \d+\.$//;
1441         # only built-in splice identifies name of uninit value
1442         s/(uninitialized value) \$\w+/$1/;
1443     }
1444
1445     # Now do the same for DB_File's version of splice
1446     my ($ms_r, $ms_error, @ms_warnings);
1447     $gather_warning = sub { push @ms_warnings, $_[0] };
1448     if ($context eq 'list') {
1449         my @r;
1450         eval {
1451             local $SIG{__WARN__} = $gather_warning;
1452             @r = splice @h, $offset, $length, @list;
1453         };
1454         $ms_error = $@;
1455         $ms_r = \@r;
1456     }
1457     elsif ($context eq 'scalar') {
1458         my $r;
1459         eval {
1460             local $SIG{__WARN__} = $gather_warning;
1461             $r = splice @h, $offset, $length, @list;
1462         };
1463         $ms_error = $@;
1464         $ms_r = [ $r ];
1465     }
1466     elsif ($context eq 'void') {
1467         eval {
1468             local $SIG{__WARN__} = $gather_warning;
1469             splice @h, $offset, $length, @list;
1470         };
1471         $ms_error = $@;
1472         $ms_r = [];
1473     }
1474     else {
1475         die "bad context $context";
1476     }
1477
1478     foreach ($ms_error, @ms_warnings) {
1479         chomp;
1480         s/ at \S+ line \d+\.?.*//s;
1481     }
1482
1483     return "different errors: '$s_error' vs '$ms_error'"
1484       if $s_error ne $ms_error;
1485     return('different return values: ' . Dumper($s_r) . ' vs ' . Dumper($ms_r))
1486       if list_diff($s_r, $ms_r);
1487     return('different changed list: ' . Dumper(\@array) . ' vs ' . Dumper(\@h))
1488       if list_diff(\@array, \@h);
1489
1490     if ((scalar @s_warnings) != (scalar @ms_warnings)) {
1491         return 'different number of warnings';
1492     }
1493
1494     while (@s_warnings) {
1495         my $sw  = shift @s_warnings;
1496         my $msw = shift @ms_warnings;
1497
1498         if (defined $sw and defined $msw) {
1499             $msw =~ s/ \(.+\)$//;
1500             $msw =~ s/ in splice$// if $] < 5.006;
1501             if ($sw ne $msw) {
1502                 return "different warning: '$sw' vs '$msw'";
1503             }
1504         }
1505         elsif (not defined $sw and not defined $msw) {
1506             # Okay.
1507         }
1508         else {
1509             return "one warning defined, another undef";
1510         }
1511     }
1512
1513     undef $H;
1514     untie @h;
1515
1516     open(TEXT, $tmp) or die "cannot open $tmp: $!";
1517     @h = <TEXT>; normalise @h; chomp @h;
1518     close TEXT or die "cannot close $tmp: $!";
1519     return('list is different when re-read from disk: '
1520            . Dumper(\@array) . ' vs ' . Dumper(\@h))
1521       if list_diff(\@array, \@h);
1522
1523     unlink $tmp;
1524
1525     return undef; # success
1526 }
1527
1528
1529 # list_diff()
1530 #
1531 # Do two lists differ?
1532 #
1533 # Parameters:
1534 #   reference to first list
1535 #   reference to second list
1536 #
1537 # Returns true iff they differ.  Only works for lists of (string or
1538 # undef).
1539 #
1540 # Surely there is a better way to do this?
1541 #
1542 sub list_diff {
1543     die 'usage: list_diff(ref to first list, ref to second list)'
1544       if @_ != 2;
1545     my ($a, $b) = @_;
1546     my @a = @$a; my @b = @$b;
1547     return 1 if (scalar @a) != (scalar @b);
1548     for (my $i = 0; $i < @a; $i++) {
1549         my ($ae, $be) = ($a[$i], $b[$i]);
1550         if (defined $ae and defined $be) {
1551             return 1 if $ae ne $be;
1552         }
1553         elsif (not defined $ae and not defined $be) {
1554             # Two undefined values are 'equal'
1555         }
1556         else {
1557             return 1;
1558         }
1559     }
1560     return 0;
1561 }
1562
1563
1564 # rand_test()
1565 #
1566 # Think up a random ARRAY, OFFSET, LENGTH, LIST, and context.
1567 # ARRAY or LIST might be empty, and OFFSET or LENGTH might be
1568 # undefined.  Return a 'test' - a listref of these five things.
1569 #
1570 sub rand_test {
1571     die 'usage: rand_test()' if @_;
1572     my @contexts = qw<list scalar void>;
1573     my $context = $contexts[int(rand @contexts)];
1574     return [ rand_list(),
1575              (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
1576              (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
1577              rand_list(),
1578              $context ];
1579 }
1580
1581
1582 sub rand_list {
1583     die 'usage: rand_list()' if @_;
1584     my @r;
1585
1586     while (rand() > 0.1 * (scalar @r + 1)) {
1587         push @r, rand_word();
1588     }
1589     return \@r;
1590 }
1591
1592
1593 sub rand_word {
1594     die 'usage: rand_word()' if @_;
1595     my $r = '';
1596     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>;
1597     while (rand() > 0.1 * (length($r) + 1)) {
1598         $r .= $chars[int(rand(scalar @chars))];
1599     }
1600     return $r;
1601 }
1602
1603