ext/DB_File/t/db-recno.t

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