ext/DB_File/t/db-recno.t

   1 #!./perl -w
   2
   3 use warnings;
   4 use strict ;
   5
   6 BEGIN {
   7     unless(grep /blib/, @INC) {
   8         chdir 't' if -d 't';
   9         @INC = '../lib' if -d '../lib';
  10     }
  11 }
  12
  13 use Config;
  14
  15 BEGIN {
  16     if(-d "lib" && -f "TEST") {
  17         if ($Config{'extensions'} !~ /\bDB_File\b/ ) {
  18             print "1..138\n";
  19             exit 0;
  20         }
  21     }
  22 }
  23
  24 use DB_File;
  25 use Fcntl;
  26 use vars qw($dbh $Dfile $bad_ones $FA) ;
  27
  28 # full tied array support started in Perl 5.004_57
  29 # Double check to see if it is available.
  30
  31 {
  32     sub try::TIEARRAY { bless [], "try" }
  33     sub try::FETCHSIZE { $FA = 1 }
  34     $FA = 0 ;
  35     my @a ;
  36     tie @a, 'try' ;
  37     my $a = @a ;
  38 }
  39
  40
  41 sub ok
  42 {
  43     my $no = shift ;
  44     my $result = shift ;
  45
  46     print "not " unless $result ;
  47     print "ok $no\n" ;
  48
  49     return $result ;
  50 }
  51
  52 {
  53     package Redirect ;
  54     use Symbol ;
  55
  56     sub new
  57     {
  58         my $class = shift ;
  59         my $filename = shift ;
  60         my $fh = gensym ;
  61         open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
  62         my $real_stdout = select($fh) ;
  63         return bless [$fh, $real_stdout ] ;
  64
  65     }
  66     sub DESTROY
  67     {
  68         my $self = shift ;
  69         close $self->[0] ;
  70         select($self->[1]) ;
  71     }
  72 }
  73
  74 sub docat
  75 {
  76     my $file = shift;
  77     local $/ = undef;
  78     open(CAT,$file) || die "Cannot open $file:$!";
  79     my $result = <CAT>;
  80     close(CAT);
  81     normalise($result) ;
  82     return $result;
  83 }
  84
  85 sub docat_del
  86 {
  87     my $file = shift;
  88     my $result = docat($file);
  89     unlink $file ;
  90     return $result;
  91 }
  92
  93 sub bad_one
  94 {
  95     print STDERR <<EOM unless $bad_ones++ ;
  96 #
  97 # Some older versions of Berkeley DB version 1 will fail tests 51,
  98 # 53 and 55.
  99 #
 100 # You can safely ignore the errors if you're never going to use the
 101 # broken functionality (recno databases with a modified bval).
 102 # Otherwise you'll have to upgrade your DB library.
 103 #
 104 # If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the
 105 # last versions that were released. Berkeley DB version 2 is continually
 106 # being updated -- Check out http://www.sleepycat.com/ for more details.
 107 #
 108 EOM
 109 }
 110
 111 sub normalise
 112 {
 113     return unless $^O eq 'cygwin' ;
 114     foreach (@_)
 115       { s#\r\n#\n#g }
 116 }
 117
 118 BEGIN
 119 {
 120     {
 121         local $SIG{__DIE__} ;
 122         eval { require Data::Dumper ; import Data::Dumper } ;
 123     }
 124
 125     if ($@) {
 126         *Dumper = sub { my $a = shift; return "[ @{ $a } ]" } ;
 127     }
 128 }
 129
 130 my $splice_tests = 10 + 1; # ten regressions, plus the randoms
 131 my $total_tests = 138 ;
 132 $total_tests += $splice_tests if $FA ;
 133 print "1..$total_tests\n";
 134
 135 my $Dfile = "recno.tmp";
 136 unlink $Dfile ;
 137
 138 umask(0);
 139
 140 # Check the interface to RECNOINFO
 141
 142 my $dbh = new DB_File::RECNOINFO ;
 143 ok(1, ! defined $dbh->{bval}) ;
 144 ok(2, ! defined $dbh->{cachesize}) ;
 145 ok(3, ! defined $dbh->{psize}) ;
 146 ok(4, ! defined $dbh->{flags}) ;
 147 ok(5, ! defined $dbh->{lorder}) ;
 148 ok(6, ! defined $dbh->{reclen}) ;
 149 ok(7, ! defined $dbh->{bfname}) ;
 150
 151 $dbh->{bval} = 3000 ;
 152 ok(8, $dbh->{bval} == 3000 );
 153
 154 $dbh->{cachesize} = 9000 ;
 155 ok(9, $dbh->{cachesize} == 9000 );
 156
 157 $dbh->{psize} = 400 ;
 158 ok(10, $dbh->{psize} == 400 );
 159
 160 $dbh->{flags} = 65 ;
 161 ok(11, $dbh->{flags} == 65 );
 162
 163 $dbh->{lorder} = 123 ;
 164 ok(12, $dbh->{lorder} == 123 );
 165
 166 $dbh->{reclen} = 1234 ;
 167 ok(13, $dbh->{reclen} == 1234 );
 168
 169 $dbh->{bfname} = 1234 ;
 170 ok(14, $dbh->{bfname} == 1234 );
 171
 172
 173 # Check that an invalid entry is caught both for store & fetch
 174 eval '$dbh->{fred} = 1234' ;
 175 ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ );
 176 eval 'my $q = $dbh->{fred}' ;
 177 ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ );
 178
 179 # Now check the interface to RECNOINFO
 180
 181 my $X  ;
 182 my @h ;
 183 ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
 184
 185 my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
 186
 187 ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640)
 188         ||  $noMode{$^O} );
 189
 190 #my $l = @h ;
 191 my $l = $X->length ;
 192 ok(19, ($FA ? @h == 0 : !$l) );
 193
 194 my @data = qw( a b c d ever f g h  i j k longername m n o p) ;
 195
 196 $h[0] = shift @data ;
 197 ok(20, $h[0] eq 'a' );
 198
 199 my $ i;
 200 foreach (@data)
 201   { $h[++$i] = $_ }
 202
 203 unshift (@data, 'a') ;
 204
 205 ok(21, defined $h[1] );
 206 ok(22, ! defined $h[16] );
 207 ok(23, $FA ? @h == @data : $X->length == @data );
 208
 209
 210 # Overwrite an entry & check fetch it
 211 $h[3] = 'replaced' ;
 212 $data[3] = 'replaced' ;
 213 ok(24, $h[3] eq 'replaced' );
 214
 215 #PUSH
 216 my @push_data = qw(added to the end) ;
 217 ($FA ? push(@h, @push_data) : $X->push(@push_data)) ;
 218 push (@data, @push_data) ;
 219 ok(25, $h[++$i] eq 'added' );
 220 ok(26, $h[++$i] eq 'to' );
 221 ok(27, $h[++$i] eq 'the' );
 222 ok(28, $h[++$i] eq 'end' );
 223
 224 # POP
 225 my $popped = pop (@data) ;
 226 my $value = ($FA ? pop @h : $X->pop) ;
 227 ok(29, $value eq $popped) ;
 228
 229 # SHIFT
 230 $value = ($FA ? shift @h : $X->shift) ;
 231 my $shifted = shift @data ;
 232 ok(30, $value eq $shifted );
 233
 234 # UNSHIFT
 235
 236 # empty list
 237 ($FA ? unshift @h,() : $X->unshift) ;
 238 ok(31, ($FA ? @h == @data : $X->length == @data ));
 239
 240 my @new_data = qw(add this to the start of the array) ;
 241 $FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ;
 242 unshift (@data, @new_data) ;
 243 ok(32, $FA ? @h == @data : $X->length == @data );
 244 ok(33, $h[0] eq "add") ;
 245 ok(34, $h[1] eq "this") ;
 246 ok(35, $h[2] eq "to") ;
 247 ok(36, $h[3] eq "the") ;
 248 ok(37, $h[4] eq "start") ;
 249 ok(38, $h[5] eq "of") ;
 250 ok(39, $h[6] eq "the") ;
 251 ok(40, $h[7] eq "array") ;
 252 ok(41, $h[8] eq $data[8]) ;
 253
 254 # Brief test for SPLICE - more thorough 'soak test' is later.
 255 my @old;
 256 if ($FA) {
 257     @old = splice(@h, 1, 2, qw(bananas just before));
 258 }
 259 else {
 260     @old = $X->splice(1, 2, qw(bananas just before));
 261 }
 262 ok(42, $h[0] eq "add") ;
 263 ok(43, $h[1] eq "bananas") ;
 264 ok(44, $h[2] eq "just") ;
 265 ok(45, $h[3] eq "before") ;
 266 ok(46, $h[4] eq "the") ;
 267 ok(47, $h[5] eq "start") ;
 268 ok(48, $h[6] eq "of") ;
 269 ok(49, $h[7] eq "the") ;
 270 ok(50, $h[8] eq "array") ;
 271 ok(51, $h[9] eq $data[8]) ;
 272 $FA ? splice(@h, 1, 3, @old) : $X->splice(1, 3, @old);
 273
 274 # Now both arrays should be identical
 275
 276 my $ok = 1 ;
 277 my $j = 0 ;
 278 foreach (@data)
 279 {
 280    $ok = 0, last if $_ ne $h[$j ++] ;
 281 }
 282 ok(52, $ok );
 283
 284 # Neagtive subscripts
 285
 286 # get the last element of the array
 287 ok(53, $h[-1] eq $data[-1] );
 288 ok(54, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] );
 289
 290 # get the first element using a negative subscript
 291 eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ;
 292 ok(55, $@ eq "" );
 293 ok(56, $h[0] eq "abcd" );
 294
 295 # now try to read before the start of the array
 296 eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ;
 297 ok(57, $@ =~ '^Modification of non-creatable array value attempted' );
 298
 299 # IMPORTANT - $X must be undefined before the untie otherwise the
 300 #             underlying DB close routine will not get called.
 301 undef $X ;
 302 untie(@h);
 303
 304 unlink $Dfile;
 305
 306
 307 {
 308     # Check bval defaults to \n
 309
 310     my @h = () ;
 311     my $dbh = new DB_File::RECNOINFO ;
 312     ok(58, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
 313     $h[0] = "abc" ;
 314     $h[1] = "def" ;
 315     $h[3] = "ghi" ;
 316     untie @h ;
 317     my $x = docat($Dfile) ;
 318     unlink $Dfile;
 319     ok(59, $x eq "abc\ndef\n\nghi\n") ;
 320 }
 321
 322 {
 323     # Change bval
 324
 325     my @h = () ;
 326     my $dbh = new DB_File::RECNOINFO ;
 327     $dbh->{bval} = "-" ;
 328     ok(60, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
 329     $h[0] = "abc" ;
 330     $h[1] = "def" ;
 331     $h[3] = "ghi" ;
 332     untie @h ;
 333     my $x = docat($Dfile) ;
 334     unlink $Dfile;
 335     my $ok = ($x eq "abc-def--ghi-") ;
 336     bad_one() unless $ok ;
 337     ok(61, $ok) ;
 338 }
 339
 340 {
 341     # Check R_FIXEDLEN with default bval (space)
 342
 343     my @h = () ;
 344     my $dbh = new DB_File::RECNOINFO ;
 345     $dbh->{flags} = R_FIXEDLEN ;
 346     $dbh->{reclen} = 5 ;
 347     ok(62, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
 348     $h[0] = "abc" ;
 349     $h[1] = "def" ;
 350     $h[3] = "ghi" ;
 351     untie @h ;
 352     my $x = docat($Dfile) ;
 353     unlink $Dfile;
 354     my $ok = ($x eq "abc  def       ghi  ") ;
 355     bad_one() unless $ok ;
 356     ok(63, $ok) ;
 357 }
 358
 359 {
 360     # Check R_FIXEDLEN with user-defined bval
 361
 362     my @h = () ;
 363     my $dbh = new DB_File::RECNOINFO ;
 364     $dbh->{flags} = R_FIXEDLEN ;
 365     $dbh->{bval} = "-" ;
 366     $dbh->{reclen} = 5 ;
 367     ok(64, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
 368     $h[0] = "abc" ;
 369     $h[1] = "def" ;
 370     $h[3] = "ghi" ;
 371     untie @h ;
 372     my $x = docat($Dfile) ;
 373     unlink $Dfile;
 374     my $ok = ($x eq "abc--def-------ghi--") ;
 375     bad_one() unless $ok ;
 376     ok(65, $ok) ;
 377 }
 378
 379 {
 380     # check that attempting to tie an associative array to a DB_RECNO will fail
 381
 382     my $filename = "xyz" ;
 383     my %x ;
 384     eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ;
 385     ok(66, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ;
 386     unlink $filename ;
 387 }
 388
 389 {
 390    # sub-class test
 391
 392    package Another ;
 393
 394    use warnings ;
 395    use strict ;
 396
 397    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
 398    print FILE <<'EOM' ;
 399
 400    package SubDB ;
 401
 402    use warnings ;
 403    use strict ;
 404    use vars qw( @ISA @EXPORT) ;
 405
 406    require Exporter ;
 407    use DB_File;
 408    @ISA=qw(DB_File);
 409    @EXPORT = @DB_File::EXPORT ;
 410
 411    sub STORE {
 412         my $self = shift ;
 413         my $key = shift ;
 414         my $value = shift ;
 415         $self->SUPER::STORE($key, $value * 2) ;
 416    }
 417
 418    sub FETCH {
 419         my $self = shift ;
 420         my $key = shift ;
 421         $self->SUPER::FETCH($key) - 1 ;
 422    }
 423
 424    sub put {
 425         my $self = shift ;
 426         my $key = shift ;
 427         my $value = shift ;
 428         $self->SUPER::put($key, $value * 3) ;
 429    }
 430
 431    sub get {
 432         my $self = shift ;
 433         $self->SUPER::get($_[0], $_[1]) ;
 434         $_[1] -= 2 ;
 435    }
 436
 437    sub A_new_method
 438    {
 439         my $self = shift ;
 440         my $key = shift ;
 441         my $value = $self->FETCH($key) ;
 442         return "[[$value]]" ;
 443    }
 444
 445    1 ;
 446 EOM
 447
 448     close FILE ;
 449
 450     BEGIN { push @INC, '.'; }
 451     eval 'use SubDB ; ';
 452     main::ok(67, $@ eq "") ;
 453     my @h ;
 454     my $X ;
 455     eval '
 456         $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO );
 457         ' ;
 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     use vars qw(@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     open(TEXT, ">$tmp") or die "cannot write to $tmp: $!";
1066     foreach (@array) { print TEXT "$_\n" }
1067     close TEXT or die "cannot close $tmp: $!";
1068
1069     my @h;
1070     my $H = tie @h, 'DB_File', $tmp, O_RDWR, 0644, $DB_RECNO
1071       or die "cannot open $tmp: $!";
1072
1073     return "basic DB_File sanity check failed"
1074       if list_diff(\@array, \@h);
1075
1076     # Output from splice():
1077     # Returned value (munged a bit), error msg, warnings
1078     #
1079     my ($s_r, $s_error, @s_warnings);
1080
1081     my $gather_warning = sub { push @s_warnings, $_[0] };
1082     if ($context eq 'list') {
1083         my @r;
1084         eval {
1085             local $SIG{__WARN__} = $gather_warning;
1086             @r = splice @array, $offset, $length, @list;
1087         };
1088         $s_error = $@;
1089         $s_r = \@r;
1090     }
1091     elsif ($context eq 'scalar') {
1092         my $r;
1093         eval {
1094             local $SIG{__WARN__} = $gather_warning;
1095             $r = splice @array, $offset, $length, @list;
1096         };
1097         $s_error = $@;
1098         $s_r = [ $r ];
1099     }
1100     elsif ($context eq 'void') {
1101         eval {
1102             local $SIG{__WARN__} = $gather_warning;
1103             splice @array, $offset, $length, @list;
1104         };
1105         $s_error = $@;
1106         $s_r = [];
1107     }
1108     else {
1109         die "bad context $context";
1110     }
1111
1112     foreach ($s_error, @s_warnings) {
1113         chomp;
1114         s/ at \S+ line \d+\.$//;
1115     }
1116
1117     # Now do the same for DB_File's version of splice
1118     my ($ms_r, $ms_error, @ms_warnings);
1119     $gather_warning = sub { push @ms_warnings, $_[0] };
1120     if ($context eq 'list') {
1121         my @r;
1122         eval {
1123             local $SIG{__WARN__} = $gather_warning;
1124             @r = splice @h, $offset, $length, @list;
1125         };
1126         $ms_error = $@;
1127         $ms_r = \@r;
1128     }
1129     elsif ($context eq 'scalar') {
1130         my $r;
1131         eval {
1132             local $SIG{__WARN__} = $gather_warning;
1133             $r = splice @h, $offset, $length, @list;
1134         };
1135         $ms_error = $@;
1136         $ms_r = [ $r ];
1137     }
1138     elsif ($context eq 'void') {
1139         eval {
1140             local $SIG{__WARN__} = $gather_warning;
1141             splice @h, $offset, $length, @list;
1142         };
1143         $ms_error = $@;
1144         $ms_r = [];
1145     }
1146     else {
1147         die "bad context $context";
1148     }
1149
1150     foreach ($ms_error, @ms_warnings) {
1151         chomp;
1152         s/ at \S+ line \d+\.?$//;
1153     }
1154
1155     return "different errors: '$s_error' vs '$ms_error'"
1156       if $s_error ne $ms_error;
1157     return('different return values: ' . Dumper($s_r) . ' vs ' . Dumper($ms_r))
1158       if list_diff($s_r, $ms_r);
1159     return('different changed list: ' . Dumper(\@array) . ' vs ' . Dumper(\@h))
1160       if list_diff(\@array, \@h);
1161
1162     if ((scalar @s_warnings) != (scalar @ms_warnings)) {
1163         return 'different number of warnings';
1164     }
1165
1166     while (@s_warnings) {
1167         my $sw  = shift @s_warnings;
1168         my $msw = shift @ms_warnings;
1169
1170         if (defined $sw and defined $msw) {
1171             $msw =~ s/ \(.+\)$//;
1172             $msw =~ s/ in splice$// if $] < 5.006;
1173             if ($sw ne $msw) {
1174                 return "different warning: '$sw' vs '$msw'";
1175             }
1176         }
1177         elsif (not defined $sw and not defined $msw) {
1178             # Okay.
1179         }
1180         else {
1181             return "one warning defined, another undef";
1182         }
1183     }
1184
1185     undef $H;
1186     untie @h;
1187
1188     open(TEXT, $tmp) or die "cannot open $tmp: $!";
1189     @h = <TEXT>; normalise @h; chomp @h;
1190     close TEXT or die "cannot close $tmp: $!";
1191     return('list is different when re-read from disk: '
1192            . Dumper(\@array) . ' vs ' . Dumper(\@h))
1193       if list_diff(\@array, \@h);
1194
1195     return undef; # success
1196 }
1197
1198
1199 # list_diff()
1200 #
1201 # Do two lists differ?
1202 #
1203 # Parameters:
1204 #   reference to first list
1205 #   reference to second list
1206 #
1207 # Returns true iff they differ.  Only works for lists of (string or
1208 # undef).
1209 #
1210 # Surely there is a better way to do this?
1211 #
1212 sub list_diff {
1213     die 'usage: list_diff(ref to first list, ref to second list)'
1214       if @_ != 2;
1215     my ($a, $b) = @_;
1216     my @a = @$a; my @b = @$b;
1217     return 1 if (scalar @a) != (scalar @b);
1218     for (my $i = 0; $i < @a; $i++) {
1219         my ($ae, $be) = ($a[$i], $b[$i]);
1220         if (defined $ae and defined $be) {
1221             return 1 if $ae ne $be;
1222         }
1223         elsif (not defined $ae and not defined $be) {
1224             # Two undefined values are 'equal'
1225         }
1226         else {
1227             return 1;
1228         }
1229     }
1230     return 0;
1231 }
1232
1233
1234 # rand_test()
1235 #
1236 # Think up a random ARRAY, OFFSET, LENGTH, LIST, and context.
1237 # ARRAY or LIST might be empty, and OFFSET or LENGTH might be
1238 # undefined.  Return a 'test' - a listref of these five things.
1239 #
1240 sub rand_test {
1241     die 'usage: rand_test()' if @_;
1242     my @contexts = qw<list scalar void>;
1243     my $context = $contexts[int(rand @contexts)];
1244     return [ rand_list(),
1245              (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
1246              (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
1247              rand_list(),
1248              $context ];
1249 }
1250
1251
1252 sub rand_list {
1253     die 'usage: rand_list()' if @_;
1254     my @r;
1255
1256     while (rand() > 0.1 * (scalar @r + 1)) {
1257         push @r, rand_word();
1258     }
1259     return \@r;
1260 }
1261
1262
1263 sub rand_word {
1264     die 'usage: rand_word()' if @_;
1265     my $r = '';
1266     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>;
1267     while (rand() > 0.1 * (length($r) + 1)) {
1268         $r .= $chars[int(rand(scalar @chars))];
1269     }
1270     return $r;
1271 }