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