← Back to branch summary

~ubuntu-branches/ubuntu/maverick/evolution-data-server/maverick-proposed

« back to all changes in this revision

Viewing changes to libdb/perl/DB_File/t/db-hash.t

  • Committer: Bazaar Package Importer
  • Author(s): Didier Roche
  • Date: 2010-05-17 17:02:06 UTC
  • mfrom: (1.1.79 upstream) (1.6.12 experimental)
  • Revision ID: james.westby@ubuntu.com-20100517170206-4ufr52vwrhh26yh0
Tags: 2.30.1-1ubuntu1
https://launchpad.net/bugs/42199
https://launchpad.net/bugs/229669
https://launchpad.net/bugs/173703
https://launchpad.net/bugs/360344
https://launchpad.net/bugs/508494
* Merge from debian experimental. Remaining change:
  (LP: #42199, #229669, #173703, #360344, #508494)
  + debian/control:
    - add Vcs-Bzr tag
    - don't use libgnome
    - Use Breaks instead of Conflicts against evolution 2.25 and earlier.
  + debian/evolution-data-server.install,
    debian/patches/45_libcamel_providers_version.patch:
    - use the upstream versioning, not a Debian-specific one 
  + debian/libedata-book1.2-dev.install, debian/libebackend-1.2-dev.install,
    debian/libcamel1.2-dev.install, debian/libedataserverui1.2-dev.install:
    - install html documentation
  + debian/rules:
    - don't build documentation it's shipped with the tarball

Show diffs side-by-side

added added

removed removed

Lines of Context:
libdb/perl/DB_File/t/db-hash.t
1
 
#!./perl 
2
 
 
3
 
BEGIN {
4
 
    unless(grep /blib/, @INC) {
5
 
        chdir 't' if -d 't';
6
 
        @INC = '../lib' if -d '../lib';
7
 
    }
8
 
}
9
 
 
10
 
use warnings;
11
 
use strict;
12
 
use Config;
13
 
 
14
 
BEGIN {
15
 
    if(-d "lib" && -f "TEST") {
16
 
        if ($Config{'extensions'} !~ /\bDB_File\b/ ) {
17
 
            print "1..0 # Skip: DB_File was not built\n";
18
 
            exit 0;
19
 
        }
20
 
    }
21
 
}
22
 
 
23
 
use DB_File; 
24
 
use Fcntl;
25
 
 
26
 
print "1..143\n";
27
 
 
28
 
sub ok
29
 
{
30
 
    my $no = shift ;
31
 
    my $result = shift ;
32
 
 
33
 
    print "not " unless $result ;
34
 
    print "ok $no\n" ;
35
 
}
36
 
 
37
 
{
38
 
    package Redirect ;
39
 
    use Symbol ;
40
 
 
41
 
    sub new
42
 
    {
43
 
        my $class = shift ;
44
 
        my $filename = shift ;
45
 
        my $fh = gensym ;
46
 
        open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
47
 
        my $real_stdout = select($fh) ;
48
 
        return bless [$fh, $real_stdout ] ;
49
 
 
50
 
    }
51
 
    sub DESTROY
52
 
    {
53
 
        my $self = shift ;
54
 
        close $self->[0] ;
55
 
        select($self->[1]) ;
56
 
    }
57
 
}
58
 
 
59
 
sub docat_del
60
 
{ 
61
 
    my $file = shift;
62
 
    local $/ = undef;
63
 
    open(CAT,$file) || die "Cannot open $file: $!";
64
 
    my $result = <CAT>;
65
 
    close(CAT);
66
 
    $result = normalise($result) ;
67
 
    unlink $file ;
68
 
    return $result;
69
 
}   
70
 
 
71
 
sub normalise
72
 
{
73
 
    my $data = shift ;
74
 
    $data =~ s#\r\n#\n#g 
75
 
        if $^O eq 'cygwin' ;
76
 
    return $data ;
77
 
}
78
 
 
79
 
sub safeUntie
80
 
{
81
 
    my $hashref = shift ;
82
 
    my $no_inner = 1;
83
 
    local $SIG{__WARN__} = sub {-- $no_inner } ;
84
 
    untie %$hashref;
85
 
    return $no_inner;
86
 
}
87
 
 
88
 
 
89
 
my $Dfile = "dbhash.tmp";
90
 
my $Dfile2 = "dbhash2.tmp";
91
 
my $null_keys_allowed = ($DB_File::db_ver < 2.004010 
92
 
                                || $DB_File::db_ver >= 3.1 );
93
 
 
94
 
unlink $Dfile;
95
 
 
96
 
umask(0);
97
 
 
98
 
# Check the interface to HASHINFO
99
 
 
100
 
my $dbh = new DB_File::HASHINFO ;
101
 
 
102
 
ok(1, ! defined $dbh->{bsize}) ;
103
 
ok(2, ! defined $dbh->{ffactor}) ;
104
 
ok(3, ! defined $dbh->{nelem}) ;
105
 
ok(4, ! defined $dbh->{cachesize}) ;
106
 
ok(5, ! defined $dbh->{hash}) ;
107
 
ok(6, ! defined $dbh->{lorder}) ;
108
 
 
109
 
$dbh->{bsize} = 3000 ;
110
 
ok(7, $dbh->{bsize} == 3000 );
111
 
 
112
 
$dbh->{ffactor} = 9000 ;
113
 
ok(8, $dbh->{ffactor} == 9000 );
114
 
 
115
 
$dbh->{nelem} = 400 ;
116
 
ok(9, $dbh->{nelem} == 400 );
117
 
 
118
 
$dbh->{cachesize} = 65 ;
119
 
ok(10, $dbh->{cachesize} == 65 );
120
 
 
121
 
my $some_sub = sub {} ;
122
 
$dbh->{hash} = $some_sub;
123
 
ok(11, $dbh->{hash} eq $some_sub );
124
 
 
125
 
$dbh->{lorder} = 1234 ;
126
 
ok(12, $dbh->{lorder} == 1234 );
127
 
 
128
 
# Check that an invalid entry is caught both for store & fetch
129
 
eval '$dbh->{fred} = 1234' ;
130
 
ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
131
 
eval 'my $q = $dbh->{fred}' ;
132
 
ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
133
 
 
134
 
 
135
 
# Now check the interface to HASH
136
 
my ($X, %h);
137
 
ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
138
 
die "Could not tie: $!" unless $X;
139
 
 
140
 
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
141
 
   $blksize,$blocks) = stat($Dfile);
142
 
 
143
 
my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
144
 
 
145
 
ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) ||
146
 
   $noMode{$^O} );
147
 
 
148
 
my ($key, $value, $i);
149
 
while (($key,$value) = each(%h)) {
150
 
    $i++;
151
 
}
152
 
ok(17, !$i );
153
 
 
154
 
$h{'goner1'} = 'snork';
155
 
 
156
 
$h{'abc'} = 'ABC';
157
 
ok(18, $h{'abc'} eq 'ABC' );
158
 
ok(19, !defined $h{'jimmy'} );
159
 
ok(20, !exists $h{'jimmy'} );
160
 
ok(21, exists $h{'abc'} );
161
 
 
162
 
$h{'def'} = 'DEF';
163
 
$h{'jkl','mno'} = "JKL\034MNO";
164
 
$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
165
 
$h{'a'} = 'A';
166
 
 
167
 
#$h{'b'} = 'B';
168
 
$X->STORE('b', 'B') ;
169
 
 
170
 
$h{'c'} = 'C';
171
 
 
172
 
#$h{'d'} = 'D';
173
 
$X->put('d', 'D') ;
174
 
 
175
 
$h{'e'} = 'E';
176
 
$h{'f'} = 'F';
177
 
$h{'g'} = 'X';
178
 
$h{'h'} = 'H';
179
 
$h{'i'} = 'I';
180
 
 
181
 
$h{'goner2'} = 'snork';
182
 
delete $h{'goner2'};
183
 
 
184
 
 
185
 
# IMPORTANT - $X must be undefined before the untie otherwise the
186
 
#             underlying DB close routine will not get called.
187
 
undef $X ;
188
 
untie(%h);
189
 
 
190
 
 
191
 
# tie to the same file again, do not supply a type - should default to HASH
192
 
ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) );
193
 
 
194
 
# Modify an entry from the previous tie
195
 
$h{'g'} = 'G';
196
 
 
197
 
$h{'j'} = 'J';
198
 
$h{'k'} = 'K';
199
 
$h{'l'} = 'L';
200
 
$h{'m'} = 'M';
201
 
$h{'n'} = 'N';
202
 
$h{'o'} = 'O';
203
 
$h{'p'} = 'P';
204
 
$h{'q'} = 'Q';
205
 
$h{'r'} = 'R';
206
 
$h{'s'} = 'S';
207
 
$h{'t'} = 'T';
208
 
$h{'u'} = 'U';
209
 
$h{'v'} = 'V';
210
 
$h{'w'} = 'W';
211
 
$h{'x'} = 'X';
212
 
$h{'y'} = 'Y';
213
 
$h{'z'} = 'Z';
214
 
 
215
 
$h{'goner3'} = 'snork';
216
 
 
217
 
delete $h{'goner1'};
218
 
$X->DELETE('goner3');
219
 
 
220
 
my @keys = keys(%h);
221
 
my @values = values(%h);
222
 
 
223
 
ok(23, $#keys == 29 && $#values == 29) ;
224
 
 
225
 
$i = 0 ;
226
 
while (($key,$value) = each(%h)) {
227
 
    if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
228
 
        $key =~ y/a-z/A-Z/;
229
 
        $i++ if $key eq $value;
230
 
    }
231
 
}
232
 
 
233
 
ok(24, $i == 30) ;
234
 
 
235
 
@keys = ('blurfl', keys(%h), 'dyick');
236
 
ok(25, $#keys == 31) ;
237
 
 
238
 
$h{'foo'} = '';
239
 
ok(26, $h{'foo'} eq '' );
240
 
 
241
 
# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
242
 
# This feature was reenabled in version 3.1 of Berkeley DB.
243
 
my $result = 0 ;
244
 
if ($null_keys_allowed) {
245
 
    $h{''} = 'bar';
246
 
    $result = ( $h{''} eq 'bar' );
247
 
}
248
 
else
249
 
  { $result = 1 }
250
 
ok(27, $result) ;
251
 
 
252
 
# check cache overflow and numeric keys and contents
253
 
my $ok = 1;
254
 
for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
255
 
for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
256
 
ok(28, $ok );
257
 
 
258
 
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
259
 
   $blksize,$blocks) = stat($Dfile);
260
 
ok(29, $size > 0 );
261
 
 
262
 
@h{0..200} = 200..400;
263
 
my @foo = @h{0..200};
264
 
ok(30, join(':',200..400) eq join(':',@foo) );
265
 
 
266
 
 
267
 
# Now check all the non-tie specific stuff
268
 
 
269
 
# Check NOOVERWRITE will make put fail when attempting to overwrite
270
 
# an existing record.
271
 
 
272
 
my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
273
 
ok(31, $status == 1 );
274
 
 
275
 
# check that the value of the key 'x' has not been changed by the 
276
 
# previous test
277
 
ok(32, $h{'x'} eq 'X' );
278
 
 
279
 
# standard put
280
 
$status = $X->put('key', 'value') ;
281
 
ok(33, $status == 0 );
282
 
 
283
 
#check that previous put can be retrieved
284
 
$value = 0 ;
285
 
$status = $X->get('key', $value) ;
286
 
ok(34, $status == 0 );
287
 
ok(35, $value eq 'value' );
288
 
 
289
 
# Attempting to delete an existing key should work
290
 
 
291
 
$status = $X->del('q') ;
292
 
ok(36, $status == 0 );
293
 
 
294
 
# Make sure that the key deleted, cannot be retrieved
295
 
{
296
 
    no warnings 'uninitialized' ;
297
 
    ok(37, $h{'q'} eq undef );
298
 
}
299
 
 
300
 
# Attempting to delete a non-existant key should fail
301
 
 
302
 
$status = $X->del('joe') ;
303
 
ok(38, $status == 1 );
304
 
 
305
 
# Check the get interface
306
 
 
307
 
# First a non-existing key
308
 
$status = $X->get('aaaa', $value) ;
309
 
ok(39, $status == 1 );
310
 
 
311
 
# Next an existing key
312
 
$status = $X->get('a', $value) ;
313
 
ok(40, $status == 0 );
314
 
ok(41, $value eq 'A' );
315
 
 
316
 
# seq
317
 
# ###
318
 
 
319
 
# ditto, but use put to replace the key/value pair.
320
 
 
321
 
# use seq to walk backwards through a file - check that this reversed is
322
 
 
323
 
# check seq FIRST/LAST
324
 
 
325
 
# sync
326
 
# ####
327
 
 
328
 
$status = $X->sync ;
329
 
ok(42, $status == 0 );
330
 
 
331
 
 
332
 
# fd
333
 
# ##
334
 
 
335
 
$status = $X->fd ;
336
 
ok(43, $status != 0 );
337
 
 
338
 
undef $X ;
339
 
untie %h ;
340
 
 
341
 
unlink $Dfile;
342
 
 
343
 
# clear
344
 
# #####
345
 
 
346
 
ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
347
 
foreach (1 .. 10)
348
 
  { $h{$_} = $_ * 100 }
349
 
 
350
 
# check that there are 10 elements in the hash
351
 
$i = 0 ;
352
 
while (($key,$value) = each(%h)) {
353
 
    $i++;
354
 
}
355
 
ok(45, $i == 10);
356
 
 
357
 
# now clear the hash
358
 
%h = () ;
359
 
 
360
 
# check it is empty
361
 
$i = 0 ;
362
 
while (($key,$value) = each(%h)) {
363
 
    $i++;
364
 
}
365
 
ok(46, $i == 0);
366
 
 
367
 
untie %h ;
368
 
unlink $Dfile ;
369
 
 
370
 
 
371
 
# Now try an in memory file
372
 
ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
373
 
 
374
 
# fd with an in memory file should return fail
375
 
$status = $X->fd ;
376
 
ok(48, $status == -1 );
377
 
 
378
 
undef $X ;
379
 
untie %h ;
380
 
 
381
 
{
382
 
    # check ability to override the default hashing
383
 
    my %x ;
384
 
    my $filename = "xyz" ;
385
 
    my $hi = new DB_File::HASHINFO ;
386
 
    $::count = 0 ;
387
 
    $hi->{hash} = sub { ++$::count ; length $_[0] } ;
388
 
    ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
389
 
    $h{"abc"} = 123 ;
390
 
    ok(50, $h{"abc"} == 123) ;
391
 
    untie %x ;
392
 
    unlink $filename ;
393
 
    ok(51, $::count >0) ;
394
 
}
395
 
 
396
 
{
397
 
    # check that attempting to tie an array to a DB_HASH will fail
398
 
 
399
 
    my $filename = "xyz" ;
400
 
    my @x ;
401
 
    eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ;
402
 
    ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ;
403
 
    unlink $filename ;
404
 
}
405
 
 
406
 
{
407
 
   # sub-class test
408
 
 
409
 
   package Another ;
410
 
 
411
 
   use warnings ;
412
 
   use strict ;
413
 
 
414
 
   open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
415
 
   print FILE <<'EOM' ;
416
 
 
417
 
   package SubDB ;
418
 
 
419
 
   use warnings ;
420
 
   use strict ;
421
 
   our (@ISA, @EXPORT);
422
 
 
423
 
   require Exporter ;
424
 
   use DB_File;
425
 
   @ISA=qw(DB_File);
426
 
   @EXPORT = @DB_File::EXPORT ;
427
 
 
428
 
   sub STORE { 
429
 
        my $self = shift ;
430
 
        my $key = shift ;
431
 
        my $value = shift ;
432
 
        $self->SUPER::STORE($key, $value * 2) ;
433
 
   }
434
 
 
435
 
   sub FETCH { 
436
 
        my $self = shift ;
437
 
        my $key = shift ;
438
 
        $self->SUPER::FETCH($key) - 1 ;
439
 
   }
440
 
 
441
 
   sub put { 
442
 
        my $self = shift ;
443
 
        my $key = shift ;
444
 
        my $value = shift ;
445
 
        $self->SUPER::put($key, $value * 3) ;
446
 
   }
447
 
 
448
 
   sub get { 
449
 
        my $self = shift ;
450
 
        $self->SUPER::get($_[0], $_[1]) ;
451
 
        $_[1] -= 2 ;
452
 
   }
453
 
 
454
 
   sub A_new_method
455
 
   {
456
 
        my $self = shift ;
457
 
        my $key = shift ;
458
 
        my $value = $self->FETCH($key) ;
459
 
        return "[[$value]]" ;
460
 
   }
461
 
 
462
 
   1 ;
463
 
EOM
464
 
 
465
 
    close FILE ;
466
 
 
467
 
    BEGIN { push @INC, '.'; }             
468
 
    eval 'use SubDB ; ';
469
 
    main::ok(53, $@ eq "") ;
470
 
    my %h ;
471
 
    my $X ;
472
 
    eval '
473
 
        $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
474
 
        ' ;
475
 
 
476
 
    main::ok(54, $@ eq "") ;
477
 
 
478
 
    my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
479
 
    main::ok(55, $@ eq "") ;
480
 
    main::ok(56, $ret == 5) ;
481
 
 
482
 
    my $value = 0;
483
 
    $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
484
 
    main::ok(57, $@ eq "") ;
485
 
    main::ok(58, $ret == 10) ;
486
 
 
487
 
    $ret = eval ' R_NEXT eq main::R_NEXT ' ;
488
 
    main::ok(59, $@ eq "" ) ;
489
 
    main::ok(60, $ret == 1) ;
490
 
 
491
 
    $ret = eval '$X->A_new_method("joe") ' ;
492
 
    main::ok(61, $@ eq "") ;
493
 
    main::ok(62, $ret eq "[[11]]") ;
494
 
 
495
 
    undef $X;
496
 
    untie(%h);
497
 
    unlink "SubDB.pm", "dbhash.tmp" ;
498
 
 
499
 
}
500
 
 
501
 
{
502
 
   # DBM Filter tests
503
 
   use warnings ;
504
 
   use strict ;
505
 
   my (%h, $db) ;
506
 
   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
507
 
   unlink $Dfile;
508
 
 
509
 
   sub checkOutput
510
 
   {
511
 
       no warnings 'uninitialized';
512
 
       my($fk, $sk, $fv, $sv) = @_ ;
513
 
 
514
 
       print "# Fetch Key   : expected '$fk' got '$fetch_key'\n" 
515
 
           if $fetch_key ne $fk ;
516
 
       print "# Fetch Value : expected '$fv' got '$fetch_value'\n" 
517
 
           if $fetch_value ne $fv ;
518
 
       print "# Store Key   : expected '$sk' got '$store_key'\n" 
519
 
           if $store_key ne $sk ;
520
 
       print "# Store Value : expected '$sv' got '$store_value'\n" 
521
 
           if $store_value ne $sv ;
522
 
       print "# \$_          : expected 'original' got '$_'\n" 
523
 
           if $_ ne 'original' ;
524
 
 
525
 
       return
526
 
           $fetch_key   eq $fk && $store_key   eq $sk && 
527
 
           $fetch_value eq $fv && $store_value eq $sv &&
528
 
           $_ eq 'original' ;
529
 
   }
530
 
   
531
 
   ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
532
 
 
533
 
   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
534
 
   $db->filter_store_key   (sub { $store_key = $_ }) ;
535
 
   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
536
 
   $db->filter_store_value (sub { $store_value = $_ }) ;
537
 
 
538
 
   $_ = "original" ;
539
 
 
540
 
   $h{"fred"} = "joe" ;
541
 
   #                   fk   sk     fv   sv
542
 
   ok(64, checkOutput( "", "fred", "", "joe")) ;
543
 
 
544
 
   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
545
 
   ok(65, $h{"fred"} eq "joe");
546
 
   #                   fk    sk     fv    sv
547
 
   ok(66, checkOutput( "", "fred", "joe", "")) ;
548
 
 
549
 
   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
550
 
   my ($k, $v) ;
551
 
   $k = 'fred';
552
 
   ok(67, ! $db->seq($k, $v, R_FIRST) ) ;
553
 
   ok(68, $k eq "fred") ;
554
 
   ok(69, $v eq "joe") ;
555
 
   #                    fk     sk  fv  sv
556
 
   ok(70, checkOutput( "fred", "fred", "joe", "")) ;
557
 
 
558
 
   # replace the filters, but remember the previous set
559
 
   my ($old_fk) = $db->filter_fetch_key   
560
 
                        (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
561
 
   my ($old_sk) = $db->filter_store_key   
562
 
                        (sub { $_ = lc $_ ; $store_key = $_ }) ;
563
 
   my ($old_fv) = $db->filter_fetch_value 
564
 
                        (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
565
 
   my ($old_sv) = $db->filter_store_value 
566
 
                        (sub { s/o/x/g; $store_value = $_ }) ;
567
 
   
568
 
   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
569
 
   $h{"Fred"} = "Joe" ;
570
 
   #                   fk   sk     fv    sv
571
 
   ok(71, checkOutput( "", "fred", "", "Jxe")) ;
572
 
 
573
 
   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
574
 
   ok(72, $h{"Fred"} eq "[Jxe]");
575
 
   #                   fk   sk     fv    sv
576
 
   ok(73, checkOutput( "", "fred", "[Jxe]", "")) ;
577
 
 
578
 
   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
579
 
   $k = 'Fred'; $v ='';
580
 
   ok(74, ! $db->seq($k, $v, R_FIRST) ) ;
581
 
   ok(75, $k eq "FRED") ;
582
 
   ok(76, $v eq "[Jxe]") ;
583
 
   #                   fk   sk     fv    sv
584
 
   ok(77, checkOutput( "FRED", "fred", "[Jxe]", "")) ;
585
 
 
586
 
   # put the original filters back
587
 
   $db->filter_fetch_key   ($old_fk);
588
 
   $db->filter_store_key   ($old_sk);
589
 
   $db->filter_fetch_value ($old_fv);
590
 
   $db->filter_store_value ($old_sv);
591
 
 
592
 
   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
593
 
   $h{"fred"} = "joe" ;
594
 
   ok(78, checkOutput( "", "fred", "", "joe")) ;
595
 
 
596
 
   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
597
 
   ok(79, $h{"fred"} eq "joe");
598
 
   ok(80, checkOutput( "", "fred", "joe", "")) ;
599
 
 
600
 
   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
601
 
   #ok(77, $db->FIRSTKEY() eq "fred") ;
602
 
   $k = 'fred';
603
 
   ok(81, ! $db->seq($k, $v, R_FIRST) ) ;
604
 
   ok(82, $k eq "fred") ;
605
 
   ok(83, $v eq "joe") ;
606
 
   #                   fk   sk     fv    sv
607
 
   ok(84, checkOutput( "fred", "fred", "joe", "")) ;
608
 
 
609
 
   # delete the filters
610
 
   $db->filter_fetch_key   (undef);
611
 
   $db->filter_store_key   (undef);
612
 
   $db->filter_fetch_value (undef);
613
 
   $db->filter_store_value (undef);
614
 
 
615
 
   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
616
 
   $h{"fred"} = "joe" ;
617
 
   ok(85, checkOutput( "", "", "", "")) ;
618
 
 
619
 
   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
620
 
   ok(86, $h{"fred"} eq "joe");
621
 
   ok(87, checkOutput( "", "", "", "")) ;
622
 
 
623
 
   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
624
 
   $k = 'fred';
625
 
   ok(88, ! $db->seq($k, $v, R_FIRST) ) ;
626
 
   ok(89, $k eq "fred") ;
627
 
   ok(90, $v eq "joe") ;
628
 
   ok(91, checkOutput( "", "", "", "")) ;
629
 
 
630
 
   undef $db ;
631
 
   untie %h;
632
 
   unlink $Dfile;
633
 
}
634
 
 
635
 
{    
636
 
    # DBM Filter with a closure
637
 
 
638
 
    use warnings ;
639
 
    use strict ;
640
 
    my (%h, $db) ;
641
 
 
642
 
    unlink $Dfile;
643
 
    ok(92, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
644
 
 
645
 
    my %result = () ;
646
 
 
647
 
    sub Closure
648
 
    {
649
 
        my ($name) = @_ ;
650
 
        my $count = 0 ;
651
 
        my @kept = () ;
652
 
 
653
 
        return sub { ++$count ; 
654
 
                     push @kept, $_ ; 
655
 
                     $result{$name} = "$name - $count: [@kept]" ;
656
 
                   }
657
 
    }
658
 
 
659
 
    $db->filter_store_key(Closure("store key")) ;
660
 
    $db->filter_store_value(Closure("store value")) ;
661
 
    $db->filter_fetch_key(Closure("fetch key")) ;
662
 
    $db->filter_fetch_value(Closure("fetch value")) ;
663
 
 
664
 
    $_ = "original" ;
665
 
 
666
 
    $h{"fred"} = "joe" ;
667
 
    ok(93, $result{"store key"} eq "store key - 1: [fred]");
668
 
    ok(94, $result{"store value"} eq "store value - 1: [joe]");
669
 
    ok(95, ! defined $result{"fetch key"} );
670
 
    ok(96, ! defined $result{"fetch value"} );
671
 
    ok(97, $_ eq "original") ;
672
 
 
673
 
    ok(98, $db->FIRSTKEY() eq "fred") ;
674
 
    ok(99, $result{"store key"} eq "store key - 1: [fred]");
675
 
    ok(100, $result{"store value"} eq "store value - 1: [joe]");
676
 
    ok(101, $result{"fetch key"} eq "fetch key - 1: [fred]");
677
 
    ok(102, ! defined $result{"fetch value"} );
678
 
    ok(103, $_ eq "original") ;
679
 
 
680
 
    $h{"jim"}  = "john" ;
681
 
    ok(104, $result{"store key"} eq "store key - 2: [fred jim]");
682
 
    ok(105, $result{"store value"} eq "store value - 2: [joe john]");
683
 
    ok(106, $result{"fetch key"} eq "fetch key - 1: [fred]");
684
 
    ok(107, ! defined $result{"fetch value"} );
685
 
    ok(108, $_ eq "original") ;
686
 
 
687
 
    ok(109, $h{"fred"} eq "joe");
688
 
    ok(110, $result{"store key"} eq "store key - 3: [fred jim fred]");
689
 
    ok(111, $result{"store value"} eq "store value - 2: [joe john]");
690
 
    ok(112, $result{"fetch key"} eq "fetch key - 1: [fred]");
691
 
    ok(113, $result{"fetch value"} eq "fetch value - 1: [joe]");
692
 
    ok(114, $_ eq "original") ;
693
 
 
694
 
    undef $db ;
695
 
    untie %h;
696
 
    unlink $Dfile;
697
 
}               
698
 
 
699
 
{
700
 
   # DBM Filter recursion detection
701
 
   use warnings ;
702
 
   use strict ;
703
 
   my (%h, $db) ;
704
 
   unlink $Dfile;
705
 
 
706
 
   ok(115, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
707
 
 
708
 
   $db->filter_store_key (sub { $_ = $h{$_} }) ;
709
 
 
710
 
   eval '$h{1} = 1234' ;
711
 
   ok(116, $@ =~ /^recursion detected in filter_store_key at/ );
712
 
   
713
 
   undef $db ;
714
 
   untie %h;
715
 
   unlink $Dfile;
716
 
}
717
 
 
718
 
 
719
 
{
720
 
   # Examples from the POD
721
 
 
722
 
  my $file = "xyzt" ;
723
 
  {
724
 
    my $redirect = new Redirect $file ;
725
 
 
726
 
    use warnings FATAL => qw(all);
727
 
    use strict ;
728
 
    use DB_File ;
729
 
    our (%h, $k, $v);
730
 
 
731
 
    unlink "fruit" ;
732
 
    tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH 
733
 
        or die "Cannot open file 'fruit': $!\n";
734
 
 
735
 
    # Add a few key/value pairs to the file
736
 
    $h{"apple"} = "red" ;
737
 
    $h{"orange"} = "orange" ;
738
 
    $h{"banana"} = "yellow" ;
739
 
    $h{"tomato"} = "red" ;
740
 
 
741
 
    # Check for existence of a key
742
 
    print "Banana Exists\n\n" if $h{"banana"} ;
743
 
 
744
 
    # Delete a key/value pair.
745
 
    delete $h{"apple"} ;
746
 
 
747
 
    # print the contents of the file
748
 
    while (($k, $v) = each %h)
749
 
      { print "$k -> $v\n" }
750
 
 
751
 
    untie %h ;
752
 
 
753
 
    unlink "fruit" ;
754
 
  }  
755
 
 
756
 
  ok(117, docat_del($file) eq <<'EOM') ;
757
 
Banana Exists
758
 
 
759
 
orange -> orange
760
 
tomato -> red
761
 
banana -> yellow
762
 
EOM
763
 
   
764
 
}
765
 
 
766
 
{
767
 
    # Bug ID 20001013.009
768
 
    #
769
 
    # test that $hash{KEY} = undef doesn't produce the warning
770
 
    #     Use of uninitialized value in null operation 
771
 
    use warnings ;
772
 
    use strict ;
773
 
    use DB_File ;
774
 
 
775
 
    unlink $Dfile;
776
 
    my %h ;
777
 
    my $a = "";
778
 
    local $SIG{__WARN__} = sub {$a = $_[0]} ;
779
 
    
780
 
    tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
781
 
    $h{ABC} = undef;
782
 
    ok(118, $a eq "") ;
783
 
    untie %h ;
784
 
    unlink $Dfile;
785
 
}
786
 
 
787
 
{
788
 
    # test that %hash = () doesn't produce the warning
789
 
    #     Argument "" isn't numeric in entersub
790
 
    use warnings ;
791
 
    use strict ;
792
 
    use DB_File ;
793
 
 
794
 
    unlink $Dfile;
795
 
    my %h ;
796
 
    my $a = "";
797
 
    local $SIG{__WARN__} = sub {$a = $_[0]} ;
798
 
    
799
 
    tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
800
 
    %h = (); ;
801
 
    ok(119, $a eq "") ;
802
 
    untie %h ;
803
 
    unlink $Dfile;
804
 
}
805
 
 
806
 
{
807
 
    # When iterating over a tied hash using "each", the key passed to FETCH
808
 
    # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
809
 
    # key in FETCH via a filter_fetch_key method we need to check that the
810
 
    # modified key doesn't get passed to NEXTKEY.
811
 
    # Also Test "keys" & "values" while we are at it.
812
 
 
813
 
    use warnings ;
814
 
    use strict ;
815
 
    use DB_File ;
816
 
 
817
 
    unlink $Dfile;
818
 
    my $bad_key = 0 ;
819
 
    my %h = () ;
820
 
    my $db ;
821
 
    ok(120, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
822
 
    $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
823
 
    $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
824
 
 
825
 
    $h{'Alpha_ABC'} = 2 ;
826
 
    $h{'Alpha_DEF'} = 5 ;
827
 
 
828
 
    ok(121, $h{'Alpha_ABC'} == 2);
829
 
    ok(122, $h{'Alpha_DEF'} == 5);
830
 
 
831
 
    my ($k, $v) = ("","");
832
 
    while (($k, $v) = each %h) {}
833
 
    ok(123, $bad_key == 0);
834
 
 
835
 
    $bad_key = 0 ;
836
 
    foreach $k (keys %h) {}
837
 
    ok(124, $bad_key == 0);
838
 
 
839
 
    $bad_key = 0 ;
840
 
    foreach $v (values %h) {}
841
 
    ok(125, $bad_key == 0);
842
 
 
843
 
    undef $db ;
844
 
    untie %h ;
845
 
    unlink $Dfile;
846
 
}
847
 
 
848
 
{
849
 
    # now an error to pass 'hash' a non-code reference
850
 
    my $dbh = new DB_File::HASHINFO ;
851
 
 
852
 
    eval { $dbh->{hash} = 2 };
853
 
    ok(126, $@ =~ /^Key 'hash' not associated with a code reference at/);
854
 
 
855
 
}
856
 
 
857
 
{
858
 
    # recursion detection in hash
859
 
    my %hash ;
860
 
    unlink $Dfile;
861
 
    my $dbh = new DB_File::HASHINFO ;
862
 
    $dbh->{hash} = sub { $hash{3} = 4 ; length $_[0] } ;
863
 
 
864
 
 
865
 
    my (%h);
866
 
    ok(127, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) );
867
 
 
868
 
    eval {      $hash{1} = 2;
869
 
                $hash{4} = 5;
870
 
         };
871
 
 
872
 
    ok(128, $@ =~ /^DB_File hash callback: recursion detected/);
873
 
    {
874
 
        no warnings;
875
 
        untie %hash;
876
 
    }
877
 
    unlink $Dfile;
878
 
}
879
 
 
880
 
{
881
 
    # Check that two hash's don't interact
882
 
    my %hash1 ;
883
 
    my %hash2 ;
884
 
    my $h1_count = 0;
885
 
    my $h2_count = 0;
886
 
    unlink $Dfile, $Dfile2;
887
 
    my $dbh1 = new DB_File::HASHINFO ;
888
 
    $dbh1->{hash} = sub { ++ $h1_count ; length $_[0] } ;
889
 
 
890
 
    my $dbh2 = new DB_File::HASHINFO ;
891
 
    $dbh2->{hash} = sub { ++ $h2_count ; length $_[0] } ;
892
 
 
893
 
 
894
 
 
895
 
    my (%h);
896
 
    ok(129, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) );
897
 
    ok(130, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) );
898
 
 
899
 
    $hash1{DEFG} = 5;
900
 
    $hash1{XYZ} = 2;
901
 
    $hash1{ABCDE} = 5;
902
 
 
903
 
    $hash2{defg} = 5;
904
 
    $hash2{xyz} = 2;
905
 
    $hash2{abcde} = 5;
906
 
 
907
 
    ok(131, $h1_count > 0);
908
 
    ok(132, $h1_count == $h2_count);
909
 
 
910
 
    ok(133, safeUntie \%hash1);
911
 
    ok(134, safeUntie \%hash2);
912
 
    unlink $Dfile, $Dfile2;
913
 
}
914
 
 
915
 
{
916
 
    # Passing undef for flags and/or mode when calling tie could cause 
917
 
    #     Use of uninitialized value in subroutine entry
918
 
    
919
 
 
920
 
    my $warn_count = 0 ;
921
 
    #local $SIG{__WARN__} = sub { ++ $warn_count };
922
 
    my %hash1;
923
 
    unlink $Dfile;
924
 
 
925
 
    tie %hash1, 'DB_File',$Dfile, undef;
926
 
    ok(135, $warn_count == 0);
927
 
    $warn_count = 0;
928
 
    tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef;
929
 
    ok(136, $warn_count == 0);
930
 
    tie %hash1, 'DB_File',$Dfile, undef, undef;
931
 
    ok(137, $warn_count == 0);
932
 
    $warn_count = 0;
933
 
 
934
 
    unlink $Dfile;
935
 
}
936
 
 
937
 
{
938
 
   # Check that DBM Filter can cope with read-only $_
939
 
 
940
 
   use warnings ;
941
 
   use strict ;
942
 
   my (%h, $db) ;
943
 
   unlink $Dfile;
944
 
 
945
 
   ok(138, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
946
 
 
947
 
   $db->filter_fetch_key   (sub { }) ;
948
 
   $db->filter_store_key   (sub { }) ;
949
 
   $db->filter_fetch_value (sub { }) ;
950
 
   $db->filter_store_value (sub { }) ;
951
 
 
952
 
   $_ = "original" ;
953
 
 
954
 
   $h{"fred"} = "joe" ;
955
 
   ok(139, $h{"fred"} eq "joe");
956
 
 
957
 
   eval { grep { $h{$_} } (1, 2, 3) };
958
 
   ok (140, ! $@);
959
 
 
960
 
 
961
 
   # delete the filters
962
 
   $db->filter_fetch_key   (undef);
963
 
   $db->filter_store_key   (undef);
964
 
   $db->filter_fetch_value (undef);
965
 
   $db->filter_store_value (undef);
966
 
 
967
 
   $h{"fred"} = "joe" ;
968
 
 
969
 
   ok(141, $h{"fred"} eq "joe");
970
 
 
971
 
   ok(142, $db->FIRSTKEY() eq "fred") ;
972
 
   
973
 
   eval { grep { $h{$_} } (1, 2, 3) };
974
 
   ok (143, ! $@);
975
 
 
976
 
   undef $db ;
977
 
   untie %h;
978
 
   unlink $Dfile;
979
 
}
980
 
 
981
 
exit ;