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