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