t/lib/dbmt_common.pl

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