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 use vars qw($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 51,
  97 # 53 and 55.
  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 my $Dfile = "recno.tmp";
 135 unlink $Dfile ;
 136
 137 umask(0);
 138
 139 # Check the interface to RECNOINFO
 140
 141 my $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    use vars qw( @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 ;
 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
 458     main::ok(68, $@ eq "") ;
 459
 460     my $ret = eval '$h[3] = 3 ; return $h[3] ' ;
 461     main::ok(69, $@ eq "") ;
 462     main::ok(70, $ret == 5) ;
 463
 464     my $value = 0;
 465     $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ;
 466     main::ok(71, $@ eq "") ;
 467     main::ok(72, $ret == 10) ;
 468
 469     $ret = eval ' R_NEXT eq main::R_NEXT ' ;
 470     main::ok(73, $@ eq "" ) ;
 471     main::ok(74, $ret == 1) ;
 472
 473     $ret = eval '$X->A_new_method(1) ' ;
 474     main::ok(75, $@ eq "") ;
 475     main::ok(76, $ret eq "[[11]]") ;
 476
 477     undef $X;
 478     untie(@h);
 479     unlink "SubDB.pm", "recno.tmp" ;
 480
 481 }
 482
 483 {
 484
 485     # test $#
 486     my $self ;
 487     unlink $Dfile;
 488     ok(77, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
 489     $h[0] = "abc" ;
 490     $h[1] = "def" ;
 491     $h[2] = "ghi" ;
 492     $h[3] = "jkl" ;
 493     ok(78, $FA ? $#h == 3 : $self->length() == 4) ;
 494     undef $self ;
 495     untie @h ;
 496     my $x = docat($Dfile) ;
 497     ok(79, $x eq "abc\ndef\nghi\njkl\n") ;
 498
 499     # $# sets array to same length
 500     ok(80, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
 501     if ($FA)
 502       { $#h = 3 }
 503     else
 504       { $self->STORESIZE(4) }
 505     ok(81, $FA ? $#h == 3 : $self->length() == 4) ;
 506     undef $self ;
 507     untie @h ;
 508     $x = docat($Dfile) ;
 509     ok(82, $x eq "abc\ndef\nghi\njkl\n") ;
 510
 511     # $# sets array to bigger
 512     ok(83, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
 513     if ($FA)
 514       { $#h = 6 }
 515     else
 516       { $self->STORESIZE(7) }
 517     ok(84, $FA ? $#h == 6 : $self->length() == 7) ;
 518     undef $self ;
 519     untie @h ;
 520     $x = docat($Dfile) ;
 521     ok(85, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ;
 522
 523     # $# sets array smaller
 524     ok(86, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
 525     if ($FA)
 526       { $#h = 2 }
 527     else
 528       { $self->STORESIZE(3) }
 529     ok(87, $FA ? $#h == 2 : $self->length() == 3) ;
 530     undef $self ;
 531     untie @h ;
 532     $x = docat($Dfile) ;
 533     ok(88, $x eq "abc\ndef\nghi\n") ;
 534
 535     unlink $Dfile;
 536
 537
 538 }
 539
 540 {
 541    # DBM Filter tests
 542    use warnings ;
 543    use strict ;
 544    my (@h, $db) ;
 545    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 546    unlink $Dfile;
 547
 548    sub checkOutput
 549    {
 550        my($fk, $sk, $fv, $sv) = @_ ;
 551        return
 552            $fetch_key eq $fk && $store_key eq $sk &&
 553            $fetch_value eq $fv && $store_value eq $sv &&
 554            $_ eq 'original' ;
 555    }
 556
 557    ok(89, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
 558
 559    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
 560    $db->filter_store_key   (sub { $store_key = $_ }) ;
 561    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
 562    $db->filter_store_value (sub { $store_value = $_ }) ;
 563
 564    $_ = "original" ;
 565
 566    $h[0] = "joe" ;
 567    #                   fk   sk     fv   sv
 568    ok(90, checkOutput( "", 0, "", "joe")) ;
 569
 570    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 571    ok(91, $h[0] eq "joe");
 572    #                   fk  sk  fv    sv
 573    ok(92, checkOutput( "", 0, "joe", "")) ;
 574
 575    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 576    ok(93, $db->FIRSTKEY() == 0) ;
 577    #                    fk     sk  fv  sv
 578    ok(94, checkOutput( 0, "", "", "")) ;
 579
 580    # replace the filters, but remember the previous set
 581    my ($old_fk) = $db->filter_fetch_key
 582                         (sub { ++ $_ ; $fetch_key = $_ }) ;
 583    my ($old_sk) = $db->filter_store_key
 584                         (sub { $_ *= 2 ; $store_key = $_ }) ;
 585    my ($old_fv) = $db->filter_fetch_value
 586                         (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
 587    my ($old_sv) = $db->filter_store_value
 588                         (sub { s/o/x/g; $store_value = $_ }) ;
 589
 590    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 591    $h[1] = "Joe" ;
 592    #                   fk   sk     fv    sv
 593    ok(95, checkOutput( "", 2, "", "Jxe")) ;
 594
 595    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 596    ok(96, $h[1] eq "[Jxe]");
 597    #                   fk   sk     fv    sv
 598    ok(97, checkOutput( "", 2, "[Jxe]", "")) ;
 599
 600    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 601    ok(98, $db->FIRSTKEY() == 1) ;
 602    #                   fk   sk     fv    sv
 603    ok(99, checkOutput( 1, "", "", "")) ;
 604
 605    # put the original filters back
 606    $db->filter_fetch_key   ($old_fk);
 607    $db->filter_store_key   ($old_sk);
 608    $db->filter_fetch_value ($old_fv);
 609    $db->filter_store_value ($old_sv);
 610
 611    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 612    $h[0] = "joe" ;
 613    ok(100, checkOutput( "", 0, "", "joe")) ;
 614
 615    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 616    ok(101, $h[0] eq "joe");
 617    ok(102, checkOutput( "", 0, "joe", "")) ;
 618
 619    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 620    ok(103, $db->FIRSTKEY() == 0) ;
 621    ok(104, checkOutput( 0, "", "", "")) ;
 622
 623    # delete the filters
 624    $db->filter_fetch_key   (undef);
 625    $db->filter_store_key   (undef);
 626    $db->filter_fetch_value (undef);
 627    $db->filter_store_value (undef);
 628
 629    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 630    $h[0] = "joe" ;
 631    ok(105, checkOutput( "", "", "", "")) ;
 632
 633    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 634    ok(106, $h[0] eq "joe");
 635    ok(107, checkOutput( "", "", "", "")) ;
 636
 637    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 638    ok(108, $db->FIRSTKEY() == 0) ;
 639    ok(109, checkOutput( "", "", "", "")) ;
 640
 641    undef $db ;
 642    untie @h;
 643    unlink $Dfile;
 644 }
 645
 646 {
 647     # DBM Filter with a closure
 648
 649     use warnings ;
 650     use strict ;
 651     my (@h, $db) ;
 652
 653     unlink $Dfile;
 654     ok(110, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
 655
 656     my %result = () ;
 657
 658     sub Closure
 659     {
 660         my ($name) = @_ ;
 661         my $count = 0 ;
 662         my @kept = () ;
 663
 664         return sub { ++$count ;
 665                      push @kept, $_ ;
 666                      $result{$name} = "$name - $count: [@kept]" ;
 667                    }
 668     }
 669
 670     $db->filter_store_key(Closure("store key")) ;
 671     $db->filter_store_value(Closure("store value")) ;
 672     $db->filter_fetch_key(Closure("fetch key")) ;
 673     $db->filter_fetch_value(Closure("fetch value")) ;
 674
 675     $_ = "original" ;
 676
 677     $h[0] = "joe" ;
 678     ok(111, $result{"store key"} eq "store key - 1: [0]");
 679     ok(112, $result{"store value"} eq "store value - 1: [joe]");
 680     ok(113, ! defined $result{"fetch key"} );
 681     ok(114, ! defined $result{"fetch value"} );
 682     ok(115, $_ eq "original") ;
 683
 684     ok(116, $db->FIRSTKEY() == 0 ) ;
 685     ok(117, $result{"store key"} eq "store key - 1: [0]");
 686     ok(118, $result{"store value"} eq "store value - 1: [joe]");
 687     ok(119, $result{"fetch key"} eq "fetch key - 1: [0]");
 688     ok(120, ! defined $result{"fetch value"} );
 689     ok(121, $_ eq "original") ;
 690
 691     $h[7]  = "john" ;
 692     ok(122, $result{"store key"} eq "store key - 2: [0 7]");
 693     ok(123, $result{"store value"} eq "store value - 2: [joe john]");
 694     ok(124, $result{"fetch key"} eq "fetch key - 1: [0]");
 695     ok(125, ! defined $result{"fetch value"} );
 696     ok(126, $_ eq "original") ;
 697
 698     ok(127, $h[0] eq "joe");
 699     ok(128, $result{"store key"} eq "store key - 3: [0 7 0]");
 700     ok(129, $result{"store value"} eq "store value - 2: [joe john]");
 701     ok(130, $result{"fetch key"} eq "fetch key - 1: [0]");
 702     ok(131, $result{"fetch value"} eq "fetch value - 1: [joe]");
 703     ok(132, $_ eq "original") ;
 704
 705     undef $db ;
 706     untie @h;
 707     unlink $Dfile;
 708 }
 709
 710 {
 711    # DBM Filter recursion detection
 712    use warnings ;
 713    use strict ;
 714    my (@h, $db) ;
 715    unlink $Dfile;
 716
 717    ok(133, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
 718
 719    $db->filter_store_key (sub { $_ = $h[0] }) ;
 720
 721    eval '$h[1] = 1234' ;
 722    ok(134, $@ =~ /^recursion detected in filter_store_key at/ );
 723
 724    undef $db ;
 725    untie @h;
 726    unlink $Dfile;
 727 }
 728
 729
 730 {
 731    # Examples from the POD
 732
 733   my $file = "xyzt" ;
 734   {
 735     my $redirect = new Redirect $file ;
 736
 737     use warnings FATAL => qw(all);
 738     use strict ;
 739     use DB_File ;
 740
 741     my $filename = "text" ;
 742     unlink $filename ;
 743
 744     my @h ;
 745     my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO
 746         or die "Cannot open file 'text': $!\n" ;
 747
 748     # Add a few key/value pairs to the file
 749     $h[0] = "orange" ;
 750     $h[1] = "blue" ;
 751     $h[2] = "yellow" ;
 752
 753     $FA ? push @h, "green", "black"
 754         : $x->push("green", "black") ;
 755
 756     my $elements = $FA ? scalar @h : $x->length ;
 757     print "The array contains $elements entries\n" ;
 758
 759     my $last = $FA ? pop @h : $x->pop ;
 760     print "popped $last\n" ;
 761
 762     $FA ? unshift @h, "white"
 763         : $x->unshift("white") ;
 764     my $first = $FA ? shift @h : $x->shift ;
 765     print "shifted $first\n" ;
 766
 767     # Check for existence of a key
 768     print "Element 1 Exists with value $h[1]\n" if $h[1] ;
 769
 770     # use a negative index
 771     print "The last element is $h[-1]\n" ;
 772     print "The 2nd last element is $h[-2]\n" ;
 773
 774     undef $x ;
 775     untie @h ;
 776
 777     unlink $filename ;
 778   }
 779
 780   ok(135, docat_del($file) eq <<'EOM') ;
 781 The array contains 5 entries
 782 popped black
 783 shifted white
 784 Element 1 Exists with value blue
 785 The last element is green
 786 The 2nd last element is yellow
 787 EOM
 788
 789   my $save_output = "xyzt" ;
 790   {
 791     my $redirect = new Redirect $save_output ;
 792
 793     use warnings FATAL => qw(all);
 794     use strict ;
 795     use vars qw(@h $H $file $i) ;
 796     use DB_File ;
 797     use Fcntl ;
 798
 799     $file = "text" ;
 800
 801     unlink $file ;
 802
 803     $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO
 804         or die "Cannot open file $file: $!\n" ;
 805
 806     # first create a text file to play with
 807     $h[0] = "zero" ;
 808     $h[1] = "one" ;
 809     $h[2] = "two" ;
 810     $h[3] = "three" ;
 811     $h[4] = "four" ;
 812
 813
 814     # Print the records in order.
 815     #
 816     # The length method is needed here because evaluating a tied
 817     # array in a scalar context does not return the number of
 818     # elements in the array.
 819
 820     print "\nORIGINAL\n" ;
 821     foreach $i (0 .. $H->length - 1) {
 822         print "$i: $h[$i]\n" ;
 823     }
 824
 825     # use the push & pop methods
 826     $a = $H->pop ;
 827     $H->push("last") ;
 828     print "\nThe last record was [$a]\n" ;
 829
 830     # and the shift & unshift methods
 831     $a = $H->shift ;
 832     $H->unshift("first") ;
 833     print "The first record was [$a]\n" ;
 834
 835     # Use the API to add a new record after record 2.
 836     $i = 2 ;
 837     $H->put($i, "Newbie", R_IAFTER) ;
 838
 839     # and a new record before record 1.
 840     $i = 1 ;
 841     $H->put($i, "New One", R_IBEFORE) ;
 842
 843     # delete record 3
 844     $H->del(3) ;
 845
 846     # now print the records in reverse order
 847     print "\nREVERSE\n" ;
 848     for ($i = $H->length - 1 ; $i >= 0 ; -- $i)
 849       { print "$i: $h[$i]\n" }
 850
 851     # same again, but use the API functions instead
 852     print "\nREVERSE again\n" ;
 853     my ($s, $k, $v)  = (0, 0, 0) ;
 854     for ($s = $H->seq($k, $v, R_LAST) ;
 855              $s == 0 ;
 856              $s = $H->seq($k, $v, R_PREV))
 857       { print "$k: $v\n" }
 858
 859     undef $H ;
 860     untie @h ;
 861
 862     unlink $file ;
 863   }
 864
 865   ok(136, docat_del($save_output) eq <<'EOM') ;
 866
 867 ORIGINAL
 868 0: zero
 869 1: one
 870 2: two
 871 3: three
 872 4: four
 873
 874 The last record was [four]
 875 The first record was [zero]
 876
 877 REVERSE
 878 5: last
 879 4: three
 880 3: Newbie
 881 2: one
 882 1: New One
 883 0: first
 884
 885 REVERSE again
 886 5: last
 887 4: three
 888 3: Newbie
 889 2: one
 890 1: New One
 891 0: first
 892 EOM
 893
 894 }
 895
 896 {
 897     # Bug ID 20001013.009
 898     #
 899     # test that $hash{KEY} = undef doesn't produce the warning
 900     #     Use of uninitialized value in null operation
 901     use warnings ;
 902     use strict ;
 903     use DB_File ;
 904
 905     unlink $Dfile;
 906     my @h ;
 907     my $a = "";
 908     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 909
 910     tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO
 911         or die "Can't open file: $!\n" ;
 912     $h[0] = undef;
 913     ok(137, $a eq "") ;
 914     untie @h ;
 915     unlink $Dfile;
 916 }
 917
 918 {
 919     # test that %hash = () doesn't produce the warning
 920     #     Argument "" isn't numeric in entersub
 921     use warnings ;
 922     use strict ;
 923     use DB_File ;
 924     my $a = "";
 925     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 926
 927     unlink $Dfile;
 928     my @h ;
 929
 930     tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO
 931         or die "Can't open file: $!\n" ;
 932     @h = (); ;
 933     ok(138, $a eq "") ;
 934     untie @h ;
 935     unlink $Dfile;
 936 }
 937
 938 # Only test splice if this is a newish version of Perl
 939 exit unless $FA ;
 940
 941 # Test SPLICE
 942 #
 943 # These are a few regression tests: bundles of five arguments to pass
 944 # to test_splice().  The first four arguments correspond to those
 945 # given to splice(), and the last says which context to call it in
 946 # (scalar, list or void).
 947 #
 948 # The expected result is not needed because we get that by running
 949 # Perl's built-in splice().
 950 #
 951 my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion',
 952                  'rarely', 'paleness' ],
 953                -4, -2,
 954                [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ],
 955                'void' ],
 956
 957              [ [ 'a' ], -2, 1, [ 'B' ], 'void' ],
 958
 959              [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ],
 960                0, -4,
 961                [ 'maids' ],
 962                'void' ],
 963
 964              [ [ 'visibility', 'pocketful', 'rectangles' ],
 965                -10, 0,
 966                [ 'garbages' ],
 967                'void' ],
 968
 969              [ [ 'sleeplessly' ],
 970                8, -4,
 971                [ 'Margery', 'clearing', 'repercussion', 'clubs',
 972                  'arise' ],
 973                'void' ],
 974
 975              [ [ 'chastises', 'recalculates' ],
 976                0, 0,
 977                [ 'momentariness', 'mediates', 'accents', 'toils',
 978                  'regaled' ],
 979                'void' ],
 980
 981              [ [ 'b', '' ],
 982                9, 8,
 983                [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
 984                'scalar' ],
 985
 986              [ [ 'b', '' ],
 987                undef, undef,
 988                [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
 989                'scalar' ],
 990
 991              [ [ 'riheb' ], -8, undef, [], 'void' ],
 992
 993              [ [ 'uft', 'qnxs', '' ],
 994                6, -2,
 995                [ 'znp', 'mhnkh', 'bn' ],
 996                'void' ],
 997             );
 998
 999 my $testnum = 139;
1000 my $failed = 0;
1001 require POSIX; my $tmp = POSIX::tmpnam();
1002 foreach my $test (@tests) {
1003     my $err = test_splice(@$test);
1004     if (defined $err) {
1005         print STDERR "# failed: ", Dumper($test);
1006         print STDERR "# error: $err\n";
1007         $failed = 1;
1008         ok($testnum++, 0);
1009     }
1010     else { ok($testnum++, 1) }
1011 }
1012
1013 if ($failed) {
1014     # Not worth running the random ones
1015     print STDERR '# skipping ', $testnum++, "\n";
1016 }
1017 else {
1018     # A thousand randomly-generated tests
1019     $failed = 0;
1020     srand(0);
1021     foreach (0 .. 1000 - 1) {
1022         my $test = rand_test();
1023         my $err = test_splice(@$test);
1024         if (defined $err) {
1025             print STDERR "# failed: ", Dumper($test);
1026             print STDERR "# error: $err\n";
1027             $failed = 1;
1028             print STDERR "# skipping any remaining random tests\n";
1029             last;
1030         }
1031     }
1032
1033     ok($testnum++, not $failed);
1034 }
1035
1036 die if $testnum != $total_tests + 1;
1037
1038 exit ;
1039
1040 # Subroutines for SPLICE testing
1041
1042 # test_splice()
1043 #
1044 # Test the new splice() against Perl's built-in one.  The first four
1045 # parameters are those passed to splice(), except that the lists must
1046 # be (explicitly) passed by reference, and are not actually modified.
1047 # (It's just a test!)  The last argument specifies the context in
1048 # which to call the functions: 'list', 'scalar', or 'void'.
1049 #
1050 # Returns:
1051 #   undef, if the two splices give the same results for the given
1052 #     arguments and context;
1053 #
1054 #   an error message showing the difference, otherwise.
1055 #
1056 # Reads global variable $tmp.
1057 #
1058 sub test_splice {
1059     die 'usage: test_splice(array, offset, length, list, context)' if @_ != 5;
1060     my ($array, $offset, $length, $list, $context) = @_;
1061     my @array = @$array;
1062     my @list = @$list;
1063
1064     open(TEXT, ">$tmp") or die "cannot write to $tmp: $!";
1065     foreach (@array) { print TEXT "$_\n" }
1066     close TEXT or die "cannot close $tmp: $!";
1067
1068     my @h;
1069     my $H = tie @h, 'DB_File', $tmp, O_RDWR, 0644, $DB_RECNO
1070       or die "cannot open $tmp: $!";
1071
1072     return "basic DB_File sanity check failed"
1073       if list_diff(\@array, \@h);
1074
1075     # Output from splice():
1076     # Returned value (munged a bit), error msg, warnings
1077     #
1078     my ($s_r, $s_error, @s_warnings);
1079
1080     my $gather_warning = sub { push @s_warnings, $_[0] };
1081     if ($context eq 'list') {
1082         my @r;
1083         eval {
1084             local $SIG{__WARN__} = $gather_warning;
1085             @r = splice @array, $offset, $length, @list;
1086         };
1087         $s_error = $@;
1088         $s_r = \@r;
1089     }
1090     elsif ($context eq 'scalar') {
1091         my $r;
1092         eval {
1093             local $SIG{__WARN__} = $gather_warning;
1094             $r = splice @array, $offset, $length, @list;
1095         };
1096         $s_error = $@;
1097         $s_r = [ $r ];
1098     }
1099     elsif ($context eq 'void') {
1100         eval {
1101             local $SIG{__WARN__} = $gather_warning;
1102             splice @array, $offset, $length, @list;
1103         };
1104         $s_error = $@;
1105         $s_r = [];
1106     }
1107     else {
1108         die "bad context $context";
1109     }
1110
1111     foreach ($s_error, @s_warnings) {
1112         chomp;
1113         s/ at \S+ line \d+\.$//;
1114     }
1115
1116     # Now do the same for DB_File's version of splice
1117     my ($ms_r, $ms_error, @ms_warnings);
1118     $gather_warning = sub { push @ms_warnings, $_[0] };
1119     if ($context eq 'list') {
1120         my @r;
1121         eval {
1122             local $SIG{__WARN__} = $gather_warning;
1123             @r = splice @h, $offset, $length, @list;
1124         };
1125         $ms_error = $@;
1126         $ms_r = \@r;
1127     }
1128     elsif ($context eq 'scalar') {
1129         my $r;
1130         eval {
1131             local $SIG{__WARN__} = $gather_warning;
1132             $r = splice @h, $offset, $length, @list;
1133         };
1134         $ms_error = $@;
1135         $ms_r = [ $r ];
1136     }
1137     elsif ($context eq 'void') {
1138         eval {
1139             local $SIG{__WARN__} = $gather_warning;
1140             splice @h, $offset, $length, @list;
1141         };
1142         $ms_error = $@;
1143         $ms_r = [];
1144     }
1145     else {
1146         die "bad context $context";
1147     }
1148
1149     foreach ($ms_error, @ms_warnings) {
1150         chomp;
1151         s/ at \S+ line \d+\.?$//;
1152     }
1153
1154     return "different errors: '$s_error' vs '$ms_error'"
1155       if $s_error ne $ms_error;
1156     return('different return values: ' . Dumper($s_r) . ' vs ' . Dumper($ms_r))
1157       if list_diff($s_r, $ms_r);
1158     return('different changed list: ' . Dumper(\@array) . ' vs ' . Dumper(\@h))
1159       if list_diff(\@array, \@h);
1160
1161     if ((scalar @s_warnings) != (scalar @ms_warnings)) {
1162         return 'different number of warnings';
1163     }
1164
1165     while (@s_warnings) {
1166         my $sw  = shift @s_warnings;
1167         my $msw = shift @ms_warnings;
1168
1169         if (defined $sw and defined $msw) {
1170             $msw =~ s/ \(.+\)$//;
1171             $msw =~ s/ in splice$// if $] < 5.006;
1172             if ($sw ne $msw) {
1173                 return "different warning: '$sw' vs '$msw'";
1174             }
1175         }
1176         elsif (not defined $sw and not defined $msw) {
1177             # Okay.
1178         }
1179         else {
1180             return "one warning defined, another undef";
1181         }
1182     }
1183
1184     undef $H;
1185     untie @h;
1186
1187     open(TEXT, $tmp) or die "cannot open $tmp: $!";
1188     @h = <TEXT>; normalise @h; chomp @h;
1189     close TEXT or die "cannot close $tmp: $!";
1190     return('list is different when re-read from disk: '
1191            . Dumper(\@array) . ' vs ' . Dumper(\@h))
1192       if list_diff(\@array, \@h);
1193
1194     return undef; # success
1195 }
1196
1197
1198 # list_diff()
1199 #
1200 # Do two lists differ?
1201 #
1202 # Parameters:
1203 #   reference to first list
1204 #   reference to second list
1205 #
1206 # Returns true iff they differ.  Only works for lists of (string or
1207 # undef).
1208 #
1209 # Surely there is a better way to do this?
1210 #
1211 sub list_diff {
1212     die 'usage: list_diff(ref to first list, ref to second list)'
1213       if @_ != 2;
1214     my ($a, $b) = @_;
1215     my @a = @$a; my @b = @$b;
1216     return 1 if (scalar @a) != (scalar @b);
1217     for (my $i = 0; $i < @a; $i++) {
1218         my ($ae, $be) = ($a[$i], $b[$i]);
1219         if (defined $ae and defined $be) {
1220             return 1 if $ae ne $be;
1221         }
1222         elsif (not defined $ae and not defined $be) {
1223             # Two undefined values are 'equal'
1224         }
1225         else {
1226             return 1;
1227         }
1228     }
1229     return 0;
1230 }
1231
1232
1233 # rand_test()
1234 #
1235 # Think up a random ARRAY, OFFSET, LENGTH, LIST, and context.
1236 # ARRAY or LIST might be empty, and OFFSET or LENGTH might be
1237 # undefined.  Return a 'test' - a listref of these five things.
1238 #
1239 sub rand_test {
1240     die 'usage: rand_test()' if @_;
1241     my @contexts = qw<list scalar void>;
1242     my $context = $contexts[int(rand @contexts)];
1243     return [ rand_list(),
1244              (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
1245              (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
1246              rand_list(),
1247              $context ];
1248 }
1249
1250
1251 sub rand_list {
1252     die 'usage: rand_list()' if @_;
1253     my @r;
1254
1255     while (rand() > 0.1 * (scalar @r + 1)) {
1256         push @r, rand_word();
1257     }
1258     return \@r;
1259 }
1260
1261
1262 sub rand_word {
1263     die 'usage: rand_word()' if @_;
1264     my $r = '';
1265     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>;
1266     while (rand() > 0.1 * (length($r) + 1)) {
1267         $r .= $chars[int(rand(scalar @chars))];
1268     }
1269     return $r;
1270 }