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