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