ext/NDBM_File/t/ndbm.t

   1 #!./perl
   2
   3 # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
   4
   5 BEGIN {
   6     require Config; import Config;
   7     if ($Config{'extensions'} !~ /\bNDBM_File\b/) {
   8         print "1..0 # Skip: NDBM_File was not built\n";
   9         exit 0;
  10     }
  11 }
  12
  13 use strict;
  14 use warnings;
  15
  16 sub ok
  17 {
  18     my $no = shift ;
  19     my $result = shift ;
  20
  21     print "not " unless $result ;
  22     print "ok $no\n" ;
  23 }
  24
  25 require NDBM_File;
  26 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
  27 use Fcntl;
  28
  29 print "1..77\n";
  30
  31 unlink <Op.dbmx*>;
  32
  33 umask(0);
  34 my %h;
  35 ok(1, tie(%h,'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640));
  36
  37 my $Dfile = "Op.dbmx.pag";
  38 if (! -e $Dfile) {
  39         ($Dfile) = <Op.dbmx*>;
  40 }
  41 if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'MacOS') {
  42     print "ok 2 # Skipped: different file permission semantics\n";
  43 }
  44 else {
  45     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  46      $blksize,$blocks) = stat($Dfile);
  47     print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
  48 }
  49 my $i = 0;
  50 while (my ($key,$value) = each(%h)) {
  51     $i++;
  52 }
  53 print (!$i ? "ok 3\n" : "not ok 3\n");
  54
  55 $h{'goner1'} = 'snork';
  56
  57 $h{'abc'} = 'ABC';
  58 $h{'def'} = 'DEF';
  59 $h{'jkl','mno'} = "JKL\034MNO";
  60 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
  61 $h{'a'} = 'A';
  62 $h{'b'} = 'B';
  63 $h{'c'} = 'C';
  64 $h{'d'} = 'D';
  65 $h{'e'} = 'E';
  66 $h{'f'} = 'F';
  67 $h{'g'} = 'G';
  68 $h{'h'} = 'H';
  69 $h{'i'} = 'I';
  70
  71 $h{'goner2'} = 'snork';
  72 delete $h{'goner2'};
  73
  74 untie(%h);
  75 print (tie(%h,'NDBM_File','Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
  76
  77 $h{'j'} = 'J';
  78 $h{'k'} = 'K';
  79 $h{'l'} = 'L';
  80 $h{'m'} = 'M';
  81 $h{'n'} = 'N';
  82 $h{'o'} = 'O';
  83 $h{'p'} = 'P';
  84 $h{'q'} = 'Q';
  85 $h{'r'} = 'R';
  86 $h{'s'} = 'S';
  87 $h{'t'} = 'T';
  88 $h{'u'} = 'U';
  89 $h{'v'} = 'V';
  90 $h{'w'} = 'W';
  91 $h{'x'} = 'X';
  92 $h{'y'} = 'Y';
  93 $h{'z'} = 'Z';
  94
  95 $h{'goner3'} = 'snork';
  96
  97 delete $h{'goner1'};
  98 delete $h{'goner3'};
  99
 100 my @keys = keys(%h);
 101 my @values = values(%h);
 102
 103 if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
 104
 105 while (my ($key,$value) = each(%h)) {
 106     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
 107         $key =~ y/a-z/A-Z/;
 108         $i++ if $key eq $value;
 109     }
 110 }
 111
 112 if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
 113
 114 @keys = ('blurfl', keys(%h), 'dyick');
 115 if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
 116
 117 $h{'foo'} = '';
 118 $h{''} = 'bar';
 119
 120 # check cache overflow and numeric keys and contents
 121 my $ok = 1;
 122 for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
 123 for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
 124 print ($ok ? "ok 8\n" : "not ok 8\n");
 125
 126 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 127    $blksize,$blocks) = stat($Dfile);
 128 print ($size > 0 ? "ok 9\n" : "not ok 9\n");
 129
 130 @h{0..200} = 200..400;
 131 my @foo = @h{0..200};
 132 print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
 133
 134 print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
 135 print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
 136
 137 untie %h;
 138 unlink <Op.dbmx*>, $Dfile;
 139
 140 {
 141    # sub-class test
 142
 143    package Another ;
 144
 145    use strict ;
 146    use warnings ;
 147
 148    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
 149    print FILE <<'EOM' ;
 150
 151    package SubDB ;
 152
 153    use strict ;
 154    use warnings ;
 155    use vars qw(@ISA @EXPORT) ;
 156
 157    require Exporter ;
 158    use NDBM_File;
 159    @ISA=qw(NDBM_File);
 160    @EXPORT = @NDBM_File::EXPORT if defined @NDBM_File::EXPORT ;
 161
 162    sub STORE {
 163         my $self = shift ;
 164         my $key = shift ;
 165         my $value = shift ;
 166         $self->SUPER::STORE($key, $value * 2) ;
 167    }
 168
 169    sub FETCH {
 170         my $self = shift ;
 171         my $key = shift ;
 172         $self->SUPER::FETCH($key) - 1 ;
 173    }
 174
 175    sub A_new_method
 176    {
 177         my $self = shift ;
 178         my $key = shift ;
 179         my $value = $self->FETCH($key) ;
 180         return "[[$value]]" ;
 181    }
 182
 183    1 ;
 184 EOM
 185
 186     close FILE ;
 187
 188     BEGIN { push @INC, '.'; }
 189
 190     eval 'use SubDB ; use Fcntl ; ';
 191     main::ok(13, $@ eq "") ;
 192     my %h ;
 193     my $X ;
 194     eval '
 195         $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 );
 196         ' ;
 197
 198     main::ok(14, $@ eq "") ;
 199
 200     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
 201     main::ok(15, $@ eq "") ;
 202     main::ok(16, $ret == 5) ;
 203
 204     $ret = eval '$X->A_new_method("fred") ' ;
 205     main::ok(17, $@ eq "") ;
 206     main::ok(18, $ret eq "[[5]]") ;
 207
 208     undef $X;
 209     untie(%h);
 210     unlink "SubDB.pm", <dbhash.tmp*> ;
 211
 212 }
 213
 214 {
 215    # DBM Filter tests
 216    use strict ;
 217    use warnings ;
 218    my (%h, $db) ;
 219    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 220
 221    sub checkOutput
 222    {
 223        my($fk, $sk, $fv, $sv) = @_ ;
 224        return
 225            $fetch_key eq $fk && $store_key eq $sk &&
 226            $fetch_value eq $fv && $store_value eq $sv &&
 227            $_ eq 'original' ;
 228    }
 229
 230    unlink <Op.dbmx*>;
 231    ok(19, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
 232
 233    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
 234    $db->filter_store_key   (sub { $store_key = $_ }) ;
 235    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
 236    $db->filter_store_value (sub { $store_value = $_ }) ;
 237
 238    $_ = "original" ;
 239
 240    $h{"fred"} = "joe" ;
 241    #                   fk   sk     fv   sv
 242    ok(20, checkOutput( "", "fred", "", "joe")) ;
 243
 244    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 245    ok(21, $h{"fred"} eq "joe");
 246    #                   fk    sk     fv    sv
 247    ok(22, checkOutput( "", "fred", "joe", "")) ;
 248
 249    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 250    ok(23, $db->FIRSTKEY() eq "fred") ;
 251    #                    fk     sk  fv  sv
 252    ok(24, checkOutput( "fred", "", "", "")) ;
 253
 254    # replace the filters, but remember the previous set
 255    my ($old_fk) = $db->filter_fetch_key
 256                         (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
 257    my ($old_sk) = $db->filter_store_key
 258                         (sub { $_ = lc $_ ; $store_key = $_ }) ;
 259    my ($old_fv) = $db->filter_fetch_value
 260                         (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
 261    my ($old_sv) = $db->filter_store_value
 262                         (sub { s/o/x/g; $store_value = $_ }) ;
 263
 264    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 265    $h{"Fred"} = "Joe" ;
 266    #                   fk   sk     fv    sv
 267    ok(25, checkOutput( "", "fred", "", "Jxe")) ;
 268
 269    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 270    ok(26, $h{"Fred"} eq "[Jxe]");
 271    #                   fk   sk     fv    sv
 272    ok(27, checkOutput( "", "fred", "[Jxe]", "")) ;
 273
 274    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 275    ok(28, $db->FIRSTKEY() eq "FRED") ;
 276    #                   fk   sk     fv    sv
 277    ok(29, checkOutput( "FRED", "", "", "")) ;
 278
 279    # put the original filters back
 280    $db->filter_fetch_key   ($old_fk);
 281    $db->filter_store_key   ($old_sk);
 282    $db->filter_fetch_value ($old_fv);
 283    $db->filter_store_value ($old_sv);
 284
 285    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 286    $h{"fred"} = "joe" ;
 287    ok(30, checkOutput( "", "fred", "", "joe")) ;
 288
 289    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 290    ok(31, $h{"fred"} eq "joe");
 291    ok(32, checkOutput( "", "fred", "joe", "")) ;
 292
 293    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 294    ok(33, $db->FIRSTKEY() eq "fred") ;
 295    ok(34, checkOutput( "fred", "", "", "")) ;
 296
 297    # delete the filters
 298    $db->filter_fetch_key   (undef);
 299    $db->filter_store_key   (undef);
 300    $db->filter_fetch_value (undef);
 301    $db->filter_store_value (undef);
 302
 303    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 304    $h{"fred"} = "joe" ;
 305    ok(35, checkOutput( "", "", "", "")) ;
 306
 307    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 308    ok(36, $h{"fred"} eq "joe");
 309    ok(37, checkOutput( "", "", "", "")) ;
 310
 311    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 312    ok(38, $db->FIRSTKEY() eq "fred") ;
 313    ok(39, checkOutput( "", "", "", "")) ;
 314
 315    undef $db ;
 316    untie %h;
 317    unlink <Op.dbmx*>;
 318 }
 319
 320 {
 321     # DBM Filter with a closure
 322
 323     use strict ;
 324     use warnings ;
 325     my (%h, $db) ;
 326
 327     unlink <Op.dbmx*>;
 328     ok(40, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
 329
 330     my %result = () ;
 331
 332     sub Closure
 333     {
 334         my ($name) = @_ ;
 335         my $count = 0 ;
 336         my @kept = () ;
 337
 338         return sub { ++$count ;
 339                      push @kept, $_ ;
 340                      $result{$name} = "$name - $count: [@kept]" ;
 341                    }
 342     }
 343
 344     $db->filter_store_key(Closure("store key")) ;
 345     $db->filter_store_value(Closure("store value")) ;
 346     $db->filter_fetch_key(Closure("fetch key")) ;
 347     $db->filter_fetch_value(Closure("fetch value")) ;
 348
 349     $_ = "original" ;
 350
 351     $h{"fred"} = "joe" ;
 352     ok(41, $result{"store key"} eq "store key - 1: [fred]");
 353     ok(42, $result{"store value"} eq "store value - 1: [joe]");
 354     ok(43, !defined $result{"fetch key"} );
 355     ok(44, !defined $result{"fetch value"} );
 356     ok(45, $_ eq "original") ;
 357
 358     ok(46, $db->FIRSTKEY() eq "fred") ;
 359     ok(47, $result{"store key"} eq "store key - 1: [fred]");
 360     ok(48, $result{"store value"} eq "store value - 1: [joe]");
 361     ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]");
 362     ok(50, ! defined $result{"fetch value"} );
 363     ok(51, $_ eq "original") ;
 364
 365     $h{"jim"}  = "john" ;
 366     ok(52, $result{"store key"} eq "store key - 2: [fred jim]");
 367     ok(53, $result{"store value"} eq "store value - 2: [joe john]");
 368     ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");
 369     ok(55, ! defined $result{"fetch value"} );
 370     ok(56, $_ eq "original") ;
 371
 372     ok(57, $h{"fred"} eq "joe");
 373     ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]");
 374     ok(59, $result{"store value"} eq "store value - 2: [joe john]");
 375     ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]");
 376     ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]");
 377     ok(62, $_ eq "original") ;
 378
 379     undef $db ;
 380     untie %h;
 381     unlink <Op.dbmx*>;
 382 }
 383
 384 {
 385    # DBM Filter recursion detection
 386    use strict ;
 387    use warnings ;
 388    my (%h, $db) ;
 389    unlink <Op.dbmx*>;
 390
 391    ok(63, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
 392
 393    $db->filter_store_key (sub { $_ = $h{$_} }) ;
 394
 395    eval '$h{1} = 1234' ;
 396    ok(64, $@ =~ /^recursion detected in filter_store_key at/ );
 397
 398    undef $db ;
 399    untie %h;
 400    unlink <Op.dbmx*>;
 401 }
 402
 403 {
 404     # Bug ID 20001013.009
 405     #
 406     # test that $hash{KEY} = undef doesn't produce the warning
 407     #     Use of uninitialized value in null operation
 408     use warnings ;
 409     use strict ;
 410     use NDBM_File ;
 411
 412     unlink <Op.dbmx*>;
 413     my %h ;
 414     my $a = "";
 415     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 416
 417     ok(65, tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
 418 }
 419
 420 {
 421     # When iterating over a tied hash using "each", the key passed to FETCH
 422     # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
 423     # key in FETCH via a filter_fetch_key method we need to check that the
 424     # modified key doesn't get passed to NEXTKEY.
 425     # Also Test "keys" & "values" while we are at it.
 426
 427     use warnings ;
 428     use strict ;
 429     use NDBM_File ;
 430
 431     unlink <Op.dbmx*>;
 432     my $bad_key = 0 ;
 433     my %h = () ;
 434     ok(66, my $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
 435     $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
 436     $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
 437
 438     $h{'Alpha_ABC'} = 2 ;
 439     $h{'Alpha_DEF'} = 5 ;
 440
 441     ok(67, $h{'Alpha_ABC'} == 2);
 442     ok(68, $h{'Alpha_DEF'} == 5);
 443
 444     my ($k, $v) = ("","");
 445     while (($k, $v) = each %h) {}
 446     ok(69, $bad_key == 0);
 447
 448     $bad_key = 0 ;
 449     foreach $k (keys %h) {}
 450     ok(70, $bad_key == 0);
 451
 452     $bad_key = 0 ;
 453     foreach $v (values %h) {}
 454     ok(71, $bad_key == 0);
 455
 456     undef $db ;
 457     untie %h ;
 458     unlink <Op.dbmx*>;
 459 }
 460
 461
 462 {
 463    # Check that DBM Filter can cope with read-only $_
 464
 465    use warnings ;
 466    use strict ;
 467    my %h ;
 468    unlink <Op.dbmx*>;
 469
 470    ok(72, my $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
 471
 472    $db->filter_fetch_key   (sub { }) ;
 473    $db->filter_store_key   (sub { }) ;
 474    $db->filter_fetch_value (sub { }) ;
 475    $db->filter_store_value (sub { }) ;
 476
 477    $_ = "original" ;
 478
 479    $h{"fred"} = "joe" ;
 480    ok(73, $h{"fred"} eq "joe");
 481
 482    eval { grep { $h{$_} } (1, 2, 3) };
 483    ok (74, ! $@);
 484
 485
 486    # delete the filters
 487    $db->filter_fetch_key   (undef);
 488    $db->filter_store_key   (undef);
 489    $db->filter_fetch_value (undef);
 490    $db->filter_store_value (undef);
 491
 492    $h{"fred"} = "joe" ;
 493
 494    ok(75, $h{"fred"} eq "joe");
 495
 496    ok(76, $db->FIRSTKEY() eq "fred") ;
 497
 498    eval { grep { $h{$_} } (1, 2, 3) };
 499    ok (77, ! $@);
 500
 501    undef $db ;
 502    untie %h;
 503    unlink <Op.dbmx*>;
 504 }
 505 exit ;