ext/SDBM_File/t/sdbm.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'} !~ /\bSDBM_File\b/) {
   8         print "1..0 # Skip: no SDBM_File\n";
   9         exit 0;
  10     }
  11 }
  12
  13 use strict;
  14 use warnings;
  15
  16 use Test::More tests => 81;
  17
  18 require SDBM_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, 'SDBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640), 'SDBM_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' || $^O eq 'dos' || $^O eq 'cygwin';
  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, 'SDBM_File', 'Op_dbmx', O_RDWR, 0640), 'SDBM_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 is(exists $h{goner1}, '');
 128 is(exists $h{foo}, 1);
 129
 130 untie %h;
 131 unlink <Op_dbmx*>, $Dfile;
 132
 133 {
 134    # sub-class test
 135
 136    package Another ;
 137
 138    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
 139    print FILE <<'EOM' ;
 140
 141    package SubDB ;
 142
 143    use strict ;
 144    use warnings ;
 145    use vars qw( @ISA @EXPORT) ;
 146
 147    require Exporter ;
 148    use SDBM_File;
 149    @ISA=qw(SDBM_File);
 150    @EXPORT = @SDBM_File::EXPORT if @SDBM_File::EXPORT ;
 151
 152    sub STORE {
 153         my $self = shift ;
 154         my $key = shift ;
 155         my $value = shift ;
 156         $self->SUPER::STORE($key, $value * 2) ;
 157    }
 158
 159    sub FETCH {
 160         my $self = shift ;
 161         my $key = shift ;
 162         $self->SUPER::FETCH($key) - 1 ;
 163    }
 164
 165    sub A_new_method
 166    {
 167         my $self = shift ;
 168         my $key = shift ;
 169         my $value = $self->FETCH($key) ;
 170         return "[[$value]]" ;
 171    }
 172
 173    1 ;
 174 EOM
 175
 176     close FILE  or die "Could not close: $!";
 177
 178     BEGIN { push @INC, '.'; }
 179     unlink <dbhash_tmp*> ;
 180
 181     eval 'use SubDB ; use Fcntl ;';
 182     main::is($@, "");
 183     my %h ;
 184     my $X ;
 185     eval '
 186         $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 );
 187         ' ;
 188
 189     main::is($@, "");
 190
 191     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
 192     main::is($@, "");
 193     main::is($ret, 5);
 194
 195     $ret = eval '$X->A_new_method("fred") ' ;
 196     main::is($@, "");
 197     main::is($ret, "[[5]]");
 198
 199     undef $X;
 200     untie(%h);
 201     unlink "SubDB.pm", <dbhash_tmp.*> ;
 202
 203 }
 204
 205 untie %h;
 206 unlink <Op_dbmx*>, $Dfile;
 207
 208 {
 209    # DBM Filter tests
 210    my (%h, $db) ;
 211    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 212
 213    sub checkOutput
 214    {
 215        my($fk, $sk, $fv, $sv) = @_ ;
 216        return
 217            $fetch_key eq $fk && $store_key eq $sk &&
 218            $fetch_value eq $fv && $store_value eq $sv &&
 219            $_ eq 'original' ;
 220    }
 221
 222    unlink <Op_dbmx*>;
 223    $db = tie %h, 'SDBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640;
 224    isa_ok($db, 'SDBM_File');
 225
 226    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
 227    $db->filter_store_key   (sub { $store_key = $_ }) ;
 228    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
 229    $db->filter_store_value (sub { $store_value = $_ }) ;
 230
 231    $_ = "original" ;
 232
 233    $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($h{"fred"}, "joe");
 239    #                   fk    sk     fv    sv
 240    ok(checkOutput("", "fred", "joe", ""));
 241
 242    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 243    is($db->FIRSTKEY(), "fred");
 244    #                    fk     sk  fv  sv
 245    ok(checkOutput("fred", "", "", ""));
 246
 247    # replace the filters, but remember the previous set
 248    my ($old_fk) = $db->filter_fetch_key
 249                         (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
 250    my ($old_sk) = $db->filter_store_key
 251                         (sub { $_ = lc $_ ; $store_key = $_ }) ;
 252    my ($old_fv) = $db->filter_fetch_value
 253                         (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
 254    my ($old_sv) = $db->filter_store_value
 255                         (sub { s/o/x/g; $store_value = $_ }) ;
 256
 257    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 258    $h{"Fred"} = "Joe" ;
 259    #                   fk   sk     fv    sv
 260    ok(checkOutput("", "fred", "", "Jxe"));
 261
 262    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 263    is($h{"Fred"}, "[Jxe]");
 264    #                   fk   sk     fv    sv
 265    ok(checkOutput("", "fred", "[Jxe]", ""));
 266
 267    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 268    is($db->FIRSTKEY(), "FRED");
 269    #                   fk   sk     fv    sv
 270    ok(checkOutput("FRED", "", "", ""));
 271
 272    # put the original filters back
 273    $db->filter_fetch_key   ($old_fk);
 274    $db->filter_store_key   ($old_sk);
 275    $db->filter_fetch_value ($old_fv);
 276    $db->filter_store_value ($old_sv);
 277
 278    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 279    $h{"fred"} = "joe" ;
 280    ok(checkOutput("", "fred", "", "joe"));
 281
 282    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 283    is($h{"fred"}, "joe");
 284    ok(checkOutput("", "fred", "joe", ""));
 285
 286    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 287    is($db->FIRSTKEY(), "fred");
 288    ok(checkOutput("fred", "", "", ""));
 289
 290    # delete the filters
 291    $db->filter_fetch_key   (undef);
 292    $db->filter_store_key   (undef);
 293    $db->filter_fetch_value (undef);
 294    $db->filter_store_value (undef);
 295
 296    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 297    $h{"fred"} = "joe" ;
 298    ok(checkOutput("", "", "", ""));
 299
 300    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 301    is($h{"fred"}, "joe");
 302    ok(checkOutput("", "", "", ""));
 303
 304    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 305    is($db->FIRSTKEY(), "fred");
 306    ok(checkOutput("", "", "", ""));
 307
 308    undef $db ;
 309    untie %h;
 310    unlink <Op_dbmx*>;
 311 }
 312
 313 {
 314     # DBM Filter with a closure
 315
 316     my (%h, $db) ;
 317
 318     unlink <Op_dbmx*>;
 319     $db = tie %h, 'SDBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640;
 320     isa_ok($db, 'SDBM_File');
 321
 322     my %result = () ;
 323
 324     sub Closure
 325     {
 326         my ($name) = @_ ;
 327         my $count = 0 ;
 328         my @kept = () ;
 329
 330         return sub { ++$count ;
 331                      push @kept, $_ ;
 332                      $result{$name} = "$name - $count: [@kept]" ;
 333                    }
 334     }
 335
 336     $db->filter_store_key(Closure("store key")) ;
 337     $db->filter_store_value(Closure("store value")) ;
 338     $db->filter_fetch_key(Closure("fetch key")) ;
 339     $db->filter_fetch_value(Closure("fetch value")) ;
 340
 341     $_ = "original" ;
 342
 343     $h{"fred"} = "joe" ;
 344     is($result{"store key"}, "store key - 1: [fred]");
 345     is($result{"store value"}, "store value - 1: [joe]");
 346     is($result{"fetch key"}, undef);
 347     is($result{"fetch value"}, undef);
 348     is($_, "original");
 349
 350     is($db->FIRSTKEY(), "fred");
 351     is($result{"store key"}, "store key - 1: [fred]");
 352     is($result{"store value"}, "store value - 1: [joe]");
 353     is($result{"fetch key"}, "fetch key - 1: [fred]");
 354     is($result{"fetch value"}, undef);
 355     is($_, "original");
 356
 357     $h{"jim"}  = "john" ;
 358     is($result{"store key"}, "store key - 2: [fred jim]");
 359     is($result{"store value"}, "store value - 2: [joe john]");
 360     is($result{"fetch key"}, "fetch key - 1: [fred]");
 361     is($result{"fetch value"}, undef);
 362     is($_, "original");
 363
 364     is($h{"fred"}, "joe");
 365     is($result{"store key"}, "store key - 3: [fred jim fred]");
 366     is($result{"store value"}, "store value - 2: [joe john]");
 367     is($result{"fetch key"}, "fetch key - 1: [fred]");
 368     is($result{"fetch value"}, "fetch value - 1: [joe]");
 369     is($_, "original");
 370
 371     undef $db ;
 372     untie %h;
 373     unlink <Op_dbmx*>;
 374 }
 375
 376 {
 377    # DBM Filter recursion detection
 378    my (%h, $db) ;
 379    unlink <Op_dbmx*>;
 380
 381    $db = tie %h, 'SDBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640;
 382    isa_ok($db, 'SDBM_File');
 383
 384    $db->filter_store_key (sub { $_ = $h{$_} }) ;
 385
 386    eval '$h{1} = 1234' ;
 387    like($@, qr/^recursion detected in filter_store_key at/);
 388
 389    undef $db ;
 390    untie %h;
 391    unlink <Op_dbmx*>;
 392 }
 393
 394 {
 395     # Bug ID 20001013.009
 396     #
 397     # test that $hash{KEY} = undef doesn't produce the warning
 398     #     Use of uninitialized value in null operation
 399
 400     unlink <Op_dbmx*>;
 401     my %h ;
 402     my $a = "";
 403     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 404
 405     isa_ok(tie(%h, 'SDBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640), 'SDBM_File');
 406     $h{ABC} = undef;
 407     is($a, "");
 408     untie %h;
 409     unlink <Op_dbmx*>;
 410 }
 411
 412 {
 413     # When iterating over a tied hash using "each", the key passed to FETCH
 414     # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
 415     # key in FETCH via a filter_fetch_key method we need to check that the
 416     # modified key doesn't get passed to NEXTKEY.
 417     # Also Test "keys" & "values" while we are at it.
 418
 419     unlink <Op_dbmx*>;
 420     my $bad_key = 0 ;
 421     my %h = () ;
 422     my $db = tie %h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640;
 423     isa_ok($db, 'SDBM_File');
 424     $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
 425     $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
 426
 427     $h{'Alpha_ABC'} = 2 ;
 428     $h{'Alpha_DEF'} = 5 ;
 429
 430     is($h{'Alpha_ABC'}, 2);
 431     is($h{'Alpha_DEF'}, 5);
 432
 433     my ($k, $v) = ("","");
 434     while (($k, $v) = each %h) {}
 435     is($bad_key, 0);
 436
 437     $bad_key = 0 ;
 438     foreach $k (keys %h) {}
 439     is($bad_key, 0);
 440
 441     $bad_key = 0 ;
 442     foreach $v (values %h) {}
 443     is($bad_key, 0);
 444
 445     undef $db ;
 446     untie %h ;
 447     unlink <Op_dbmx*>;
 448 }
 449
 450
 451 {
 452    # Check that DBM Filter can cope with read-only $_
 453
 454    my %h ;
 455    unlink <Op1_dbmx*>;
 456
 457    my $db = tie %h, 'SDBM_File', 'Op1_dbmx', O_RDWR|O_CREAT, 0640;
 458    isa_ok($db, 'SDBM_File');
 459
 460    $db->filter_fetch_key   (sub { }) ;
 461    $db->filter_store_key   (sub { }) ;
 462    $db->filter_fetch_value (sub { }) ;
 463    $db->filter_store_value (sub { }) ;
 464
 465    $_ = "original" ;
 466
 467    $h{"fred"} = "joe" ;
 468    is($h{"fred"}, "joe");
 469
 470    eval { grep { $h{$_} } (1, 2, 3) };
 471    is($@, '');
 472
 473
 474    # delete the filters
 475    $db->filter_fetch_key   (undef);
 476    $db->filter_store_key   (undef);
 477    $db->filter_fetch_value (undef);
 478    $db->filter_store_value (undef);
 479
 480    $h{"fred"} = "joe" ;
 481
 482    is($h{"fred"}, "joe");
 483
 484    is($db->FIRSTKEY(), "fred");
 485
 486    eval { map { $h{$_} } (1, 2, 3) };
 487    is($@, '');
 488
 489    undef $db ;
 490    untie %h;
 491    unlink <Op1_dbmx*>;
 492 }