← 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/BerkeleyDB/t/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/BerkeleyDB/t/hash.t
1
 
#!./perl -w
2
 
 
3
 
# ID: %I%, %G%   
4
 
 
5
 
use strict ;
6
 
 
7
 
BEGIN {
8
 
    unless(grep /blib/, @INC) {
9
 
        chdir 't' if -d 't';
10
 
        @INC = '../lib' if -d '../lib';
11
 
    }
12
 
}
13
 
 
14
 
use BerkeleyDB; 
15
 
use t::util ;
16
 
 
17
 
print "1..212\n";
18
 
 
19
 
my $Dfile = "dbhash.tmp";
20
 
my $Dfile2 = "dbhash2.tmp";
21
 
my $Dfile3 = "dbhash3.tmp";
22
 
unlink $Dfile;
23
 
 
24
 
umask(0) ;
25
 
 
26
 
 
27
 
# Check for invalid parameters
28
 
{
29
 
    # Check for invalid parameters
30
 
    my $db ;
31
 
    eval ' $db = new BerkeleyDB::Hash  -Stupid => 3 ; ' ;
32
 
    ok 1, $@ =~ /unknown key value\(s\) Stupid/  ;
33
 
 
34
 
    eval ' $db = new BerkeleyDB::Hash -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
35
 
    ok 2, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/  ;
36
 
 
37
 
    eval ' $db = new BerkeleyDB::Hash -Env => 2 ' ;
38
 
    ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
39
 
 
40
 
    eval ' $db = new BerkeleyDB::Hash -Txn => "fred" ' ;
41
 
    ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
42
 
 
43
 
    my $obj = bless [], "main" ;
44
 
    eval ' $db = new BerkeleyDB::Hash -Env => $obj ' ;
45
 
    ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
46
 
}
47
 
 
48
 
# Now check the interface to HASH
49
 
 
50
 
{
51
 
    my $lex = new LexFile $Dfile ;
52
 
 
53
 
    ok 6, my $db = new BerkeleyDB::Hash -Filename => $Dfile, 
54
 
                                    -Flags    => DB_CREATE ;
55
 
 
56
 
    # Add a k/v pair
57
 
    my $value ;
58
 
    my $status ;
59
 
    ok 7, $db->db_put("some key", "some value") == 0  ;
60
 
    ok 8, $db->status() == 0 ;
61
 
    ok 9, $db->db_get("some key", $value) == 0 ;
62
 
    ok 10, $value eq "some value" ;
63
 
    ok 11, $db->db_put("key", "value") == 0  ;
64
 
    ok 12, $db->db_get("key", $value) == 0 ;
65
 
    ok 13, $value eq "value" ;
66
 
    ok 14, $db->db_del("some key") == 0 ;
67
 
    ok 15, ($status = $db->db_get("some key", $value)) == DB_NOTFOUND ;
68
 
    ok 16, $status eq $DB_errors{'DB_NOTFOUND'} ;
69
 
    ok 17, $db->status() == DB_NOTFOUND ;
70
 
    ok 18, $db->status() eq $DB_errors{'DB_NOTFOUND'};
71
 
 
72
 
    ok 19, $db->db_sync() == 0 ;
73
 
 
74
 
    # Check NOOVERWRITE will make put fail when attempting to overwrite
75
 
    # an existing record.
76
 
 
77
 
    ok 20, $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
78
 
    ok 21, $db->status() eq $DB_errors{'DB_KEYEXIST'};
79
 
    ok 22, $db->status() == DB_KEYEXIST ;
80
 
 
81
 
    # check that the value of the key  has not been changed by the
82
 
    # previous test
83
 
    ok 23, $db->db_get("key", $value) == 0 ;
84
 
    ok 24, $value eq "value" ;
85
 
 
86
 
    # test DB_GET_BOTH
87
 
    my ($k, $v) = ("key", "value") ;
88
 
    ok 25, $db->db_get($k, $v, DB_GET_BOTH) == 0 ;
89
 
 
90
 
    ($k, $v) = ("key", "fred") ;
91
 
    ok 26, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
92
 
 
93
 
    ($k, $v) = ("another", "value") ;
94
 
    ok 27, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
95
 
 
96
 
 
97
 
}
98
 
 
99
 
{
100
 
    # Check simple env works with a hash.
101
 
    my $lex = new LexFile $Dfile ;
102
 
 
103
 
    my $home = "./fred" ;
104
 
    ok 28, my $lexD = new LexDir($home);
105
 
 
106
 
    ok 29, my $env = new BerkeleyDB::Env -Flags => DB_CREATE| DB_INIT_MPOOL,
107
 
                                         -Home  => $home ;
108
 
    ok 30, my $db = new BerkeleyDB::Hash -Filename => $Dfile, 
109
 
                                    -Env      => $env,
110
 
                                    -Flags    => DB_CREATE ;
111
 
 
112
 
    # Add a k/v pair
113
 
    my $value ;
114
 
    ok 31, $db->db_put("some key", "some value") == 0 ;
115
 
    ok 32, $db->db_get("some key", $value) == 0 ;
116
 
    ok 33, $value eq "some value" ;
117
 
    undef $db ;
118
 
    undef $env ;
119
 
}
120
 
 
121
 
{
122
 
    # override default hash
123
 
    my $lex = new LexFile $Dfile ;
124
 
    my $value ;
125
 
    $::count = 0 ;
126
 
    ok 34, my $db = new BerkeleyDB::Hash -Filename => $Dfile, 
127
 
                                     -Hash     => sub {  ++$::count ; length $_[0] },
128
 
                                     -Flags    => DB_CREATE ;
129
 
 
130
 
    ok 35, $db->db_put("some key", "some value") == 0 ;
131
 
    ok 36, $db->db_get("some key", $value) == 0 ;
132
 
    ok 37, $value eq "some value" ;
133
 
    ok 38, $::count > 0 ;
134
 
 
135
 
}
136
 
 
137
 
{
138
 
    # cursors
139
 
 
140
 
    my $lex = new LexFile $Dfile ;
141
 
    my %hash ;
142
 
    my ($k, $v) ;
143
 
    ok 39, my $db = new BerkeleyDB::Hash -Filename => $Dfile, 
144
 
                                     -Flags    => DB_CREATE ;
145
 
 
146
 
    # create some data
147
 
    my %data =  (
148
 
                "red"   => 2,
149
 
                "green" => "house",
150
 
                "blue"  => "sea",
151
 
                ) ;
152
 
 
153
 
    my $ret = 0 ;
154
 
    while (($k, $v) = each %data) {
155
 
        $ret += $db->db_put($k, $v) ;
156
 
    }
157
 
    ok 40, $ret == 0 ;
158
 
 
159
 
    # create the cursor
160
 
    ok 41, my $cursor = $db->db_cursor() ;
161
 
 
162
 
    $k = $v = "" ;
163
 
    my %copy = %data ;
164
 
    my $extras = 0 ;
165
 
    # sequence forwards
166
 
    while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
167
 
        if ( $copy{$k} eq $v ) 
168
 
            { delete $copy{$k} }
169
 
        else
170
 
            { ++ $extras }
171
 
    }
172
 
    ok 42, $cursor->status() == DB_NOTFOUND ;
173
 
    ok 43, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
174
 
    ok 44, keys %copy == 0 ;
175
 
    ok 45, $extras == 0 ;
176
 
 
177
 
    # sequence backwards
178
 
    %copy = %data ;
179
 
    $extras = 0 ;
180
 
    my $status ;
181
 
    for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
182
 
          $status == 0 ;
183
 
          $status = $cursor->c_get($k, $v, DB_PREV)) {
184
 
        if ( $copy{$k} eq $v ) 
185
 
            { delete $copy{$k} }
186
 
        else
187
 
            { ++ $extras }
188
 
    }
189
 
    ok 46, $status == DB_NOTFOUND ;
190
 
    ok 47, $status eq $DB_errors{'DB_NOTFOUND'} ;
191
 
    ok 48, $cursor->status() == $status ;
192
 
    ok 49, $cursor->status() eq $status ;
193
 
    ok 50, keys %copy == 0 ;
194
 
    ok 51, $extras == 0 ;
195
 
 
196
 
    ($k, $v) = ("green", "house") ;
197
 
    ok 52, $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ;
198
 
 
199
 
    ($k, $v) = ("green", "door") ;
200
 
    ok 53, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
201
 
 
202
 
    ($k, $v) = ("black", "house") ;
203
 
    ok 54, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
204
 
    
205
 
}
206
 
 
207
 
{
208
 
    # Tied Hash interface
209
 
 
210
 
    my $lex = new LexFile $Dfile ;
211
 
    my %hash ;
212
 
    ok 55, tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
213
 
                                      -Flags    => DB_CREATE ;
214
 
 
215
 
    # check "each" with an empty database
216
 
    my $count = 0 ;
217
 
    while (my ($k, $v) = each %hash) {
218
 
        ++ $count ;
219
 
    }
220
 
    ok 56, (tied %hash)->status() == DB_NOTFOUND ;
221
 
    ok 57, $count == 0 ;
222
 
 
223
 
    # Add a k/v pair
224
 
    my $value ;
225
 
    $hash{"some key"} = "some value";
226
 
    ok 58, (tied %hash)->status() == 0 ;
227
 
    ok 59, $hash{"some key"} eq "some value";
228
 
    ok 60, defined $hash{"some key"} ;
229
 
    ok 61, (tied %hash)->status() == 0 ;
230
 
    ok 62, exists $hash{"some key"} ;
231
 
    ok 63, !defined $hash{"jimmy"} ;
232
 
    ok 64, (tied %hash)->status() == DB_NOTFOUND ;
233
 
    ok 65, !exists $hash{"jimmy"} ;
234
 
    ok 66, (tied %hash)->status() == DB_NOTFOUND ;
235
 
 
236
 
    delete $hash{"some key"} ;
237
 
    ok 67, (tied %hash)->status() == 0 ;
238
 
    ok 68, ! defined $hash{"some key"} ;
239
 
    ok 69, (tied %hash)->status() == DB_NOTFOUND ;
240
 
    ok 70, ! exists $hash{"some key"} ;
241
 
    ok 71, (tied %hash)->status() == DB_NOTFOUND ;
242
 
 
243
 
    $hash{1} = 2 ;
244
 
    $hash{10} = 20 ;
245
 
    $hash{1000} = 2000 ;
246
 
 
247
 
    my ($keys, $values) = (0,0);
248
 
    $count = 0 ;
249
 
    while (my ($k, $v) = each %hash) {
250
 
        $keys += $k ;
251
 
        $values += $v ;
252
 
        ++ $count ;
253
 
    }
254
 
    ok 72, $count == 3 ;
255
 
    ok 73, $keys == 1011 ;
256
 
    ok 74, $values == 2022 ;
257
 
 
258
 
    # now clear the hash
259
 
    %hash = () ;
260
 
    ok 75, keys %hash == 0 ;
261
 
 
262
 
    untie %hash ;
263
 
}
264
 
 
265
 
{
266
 
    # in-memory file
267
 
 
268
 
    my $lex = new LexFile $Dfile ;
269
 
    my %hash ;
270
 
    my $fd ;
271
 
    my $value ;
272
 
    ok 76, my $db = tie %hash, 'BerkeleyDB::Hash' ;
273
 
 
274
 
    ok 77, $db->db_put("some key", "some value") == 0  ;
275
 
    ok 78, $db->db_get("some key", $value) == 0 ;
276
 
    ok 79, $value eq "some value" ;
277
 
 
278
 
    undef $db ;
279
 
    untie %hash ;
280
 
}
281
 
 
282
 
{
283
 
    # partial
284
 
    # check works via API
285
 
 
286
 
    my $lex = new LexFile $Dfile ;
287
 
    my %hash ;
288
 
    my $value ;
289
 
    ok 80, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
290
 
                                               -Flags    => DB_CREATE ;
291
 
 
292
 
    # create some data
293
 
    my %data =  (
294
 
                "red"   => "boat",
295
 
                "green" => "house",
296
 
                "blue"  => "sea",
297
 
                ) ;
298
 
 
299
 
    my $ret = 0 ;
300
 
    while (my ($k, $v) = each %data) {
301
 
        $ret += $db->db_put($k, $v) ;
302
 
    }
303
 
    ok 81, $ret == 0 ;
304
 
 
305
 
 
306
 
    # do a partial get
307
 
    my($pon, $off, $len) = $db->partial_set(0,2) ;
308
 
    ok 82, $pon == 0 && $off == 0 && $len == 0 ;
309
 
    ok 83, ( $db->db_get("red", $value) == 0) && $value eq "bo" ;
310
 
    ok 84, ( $db->db_get("green", $value) == 0) && $value eq "ho" ;
311
 
    ok 85, ( $db->db_get("blue", $value) == 0) && $value eq "se" ;
312
 
 
313
 
    # do a partial get, off end of data
314
 
    ($pon, $off, $len) = $db->partial_set(3,2) ;
315
 
    ok 86, $pon ;
316
 
    ok 87, $off == 0 ;
317
 
    ok 88, $len == 2 ;
318
 
    ok 89, $db->db_get("red", $value) == 0 && $value eq "t" ;
319
 
    ok 90, $db->db_get("green", $value) == 0 && $value eq "se" ;
320
 
    ok 91, $db->db_get("blue", $value) == 0 && $value eq "" ;
321
 
 
322
 
    # switch of partial mode
323
 
    ($pon, $off, $len) = $db->partial_clear() ;
324
 
    ok 92, $pon ;
325
 
    ok 93, $off == 3 ;
326
 
    ok 94, $len == 2 ;
327
 
    ok 95, $db->db_get("red", $value) == 0 && $value eq "boat" ;
328
 
    ok 96, $db->db_get("green", $value) == 0 && $value eq "house" ;
329
 
    ok 97, $db->db_get("blue", $value) == 0 && $value eq "sea" ;
330
 
 
331
 
    # now partial put
332
 
    ($pon, $off, $len) = $db->partial_set(0,2) ;
333
 
    ok 98, ! $pon ;
334
 
    ok 99, $off == 0 ;
335
 
    ok 100, $len == 0 ;
336
 
    ok 101, $db->db_put("red", "") == 0 ;
337
 
    ok 102, $db->db_put("green", "AB") == 0 ;
338
 
    ok 103, $db->db_put("blue", "XYZ") == 0 ;
339
 
    ok 104, $db->db_put("new", "KLM") == 0 ;
340
 
 
341
 
    $db->partial_clear() ;
342
 
    ok 105, $db->db_get("red", $value) == 0 && $value eq "at" ;
343
 
    ok 106, $db->db_get("green", $value) == 0 && $value eq "ABuse" ;
344
 
    ok 107, $db->db_get("blue", $value) == 0 && $value eq "XYZa" ;
345
 
    ok 108, $db->db_get("new", $value) == 0 && $value eq "KLM" ;
346
 
 
347
 
    # now partial put
348
 
    $db->partial_set(3,2) ;
349
 
    ok 109, $db->db_put("red", "PPP") == 0 ;
350
 
    ok 110, $db->db_put("green", "Q") == 0 ;
351
 
    ok 111, $db->db_put("blue", "XYZ") == 0 ;
352
 
    ok 112, $db->db_put("new", "--") == 0 ;
353
 
 
354
 
    ($pon, $off, $len) = $db->partial_clear() ;
355
 
    ok 113, $pon ;
356
 
    ok 114, $off == 3 ;
357
 
    ok 115, $len == 2 ;
358
 
    ok 116, $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ;
359
 
    ok 117, $db->db_get("green", $value) == 0 && $value eq "ABuQ" ;
360
 
    ok 118, $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ;
361
 
    ok 119, $db->db_get("new", $value) == 0 && $value eq "KLM--" ;
362
 
}
363
 
 
364
 
{
365
 
    # partial
366
 
    # check works via tied hash 
367
 
 
368
 
    my $lex = new LexFile $Dfile ;
369
 
    my %hash ;
370
 
    my $value ;
371
 
    ok 120, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
372
 
                                               -Flags    => DB_CREATE ;
373
 
 
374
 
    # create some data
375
 
    my %data =  (
376
 
                "red"   => "boat",
377
 
                "green" => "house",
378
 
                "blue"  => "sea",
379
 
                ) ;
380
 
 
381
 
    while (my ($k, $v) = each %data) {
382
 
        $hash{$k} = $v ;
383
 
    }
384
 
 
385
 
 
386
 
    # do a partial get
387
 
    $db->partial_set(0,2) ;
388
 
    ok 121, $hash{"red"} eq "bo" ;
389
 
    ok 122, $hash{"green"} eq "ho" ;
390
 
    ok 123, $hash{"blue"}  eq "se" ;
391
 
 
392
 
    # do a partial get, off end of data
393
 
    $db->partial_set(3,2) ;
394
 
    ok 124, $hash{"red"} eq "t" ;
395
 
    ok 125, $hash{"green"} eq "se" ;
396
 
    ok 126, $hash{"blue"} eq "" ;
397
 
 
398
 
    # switch of partial mode
399
 
    $db->partial_clear() ;
400
 
    ok 127, $hash{"red"} eq "boat" ;
401
 
    ok 128, $hash{"green"} eq "house" ;
402
 
    ok 129, $hash{"blue"} eq "sea" ;
403
 
 
404
 
    # now partial put
405
 
    $db->partial_set(0,2) ;
406
 
    ok 130, $hash{"red"} = "" ;
407
 
    ok 131, $hash{"green"} = "AB" ;
408
 
    ok 132, $hash{"blue"} = "XYZ" ;
409
 
    ok 133, $hash{"new"} = "KLM" ;
410
 
 
411
 
    $db->partial_clear() ;
412
 
    ok 134, $hash{"red"} eq "at" ;
413
 
    ok 135, $hash{"green"} eq "ABuse" ;
414
 
    ok 136, $hash{"blue"} eq "XYZa" ;
415
 
    ok 137, $hash{"new"} eq "KLM" ;
416
 
 
417
 
    # now partial put
418
 
    $db->partial_set(3,2) ;
419
 
    ok 138, $hash{"red"} = "PPP" ;
420
 
    ok 139, $hash{"green"} = "Q" ;
421
 
    ok 140, $hash{"blue"} = "XYZ" ;
422
 
    ok 141, $hash{"new"} = "TU" ;
423
 
 
424
 
    $db->partial_clear() ;
425
 
    ok 142, $hash{"red"} eq "at\0PPP" ;
426
 
    ok 143, $hash{"green"} eq "ABuQ" ;
427
 
    ok 144, $hash{"blue"} eq "XYZXYZ" ;
428
 
    ok 145, $hash{"new"} eq "KLMTU" ;
429
 
}
430
 
 
431
 
{
432
 
    # transaction
433
 
 
434
 
    my $lex = new LexFile $Dfile ;
435
 
    my %hash ;
436
 
    my $value ;
437
 
 
438
 
    my $home = "./fred" ;
439
 
    ok 146, my $lexD = new LexDir($home);
440
 
    ok 147, my $env = new BerkeleyDB::Env -Home => $home,
441
 
                                     -Flags => DB_CREATE|DB_INIT_TXN|
442
 
                                                DB_INIT_MPOOL|DB_INIT_LOCK ;
443
 
    ok 148, my $txn = $env->txn_begin() ;
444
 
    ok 149, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
445
 
                                                -Flags     => DB_CREATE ,
446
 
                                                -Env       => $env,
447
 
                                                -Txn       => $txn  ;
448
 
 
449
 
    
450
 
    ok 150, $txn->txn_commit() == 0 ;
451
 
    ok 151, $txn = $env->txn_begin() ;
452
 
    $db1->Txn($txn);
453
 
    # create some data
454
 
    my %data =  (
455
 
                "red"   => "boat",
456
 
                "green" => "house",
457
 
                "blue"  => "sea",
458
 
                ) ;
459
 
 
460
 
    my $ret = 0 ;
461
 
    while (my ($k, $v) = each %data) {
462
 
        $ret += $db1->db_put($k, $v) ;
463
 
    }
464
 
    ok 152, $ret == 0 ;
465
 
 
466
 
    # should be able to see all the records
467
 
 
468
 
    ok 153, my $cursor = $db1->db_cursor() ;
469
 
    my ($k, $v) = ("", "") ;
470
 
    my $count = 0 ;
471
 
    # sequence forwards
472
 
    while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
473
 
        ++ $count ;
474
 
    }
475
 
    ok 154, $count == 3 ;
476
 
    undef $cursor ;
477
 
 
478
 
    # now abort the transaction
479
 
    ok 155, $txn->txn_abort() == 0 ;
480
 
 
481
 
    # there shouldn't be any records in the database
482
 
    $count = 0 ;
483
 
    # sequence forwards
484
 
    ok 156, $cursor = $db1->db_cursor() ;
485
 
    while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
486
 
        ++ $count ;
487
 
    }
488
 
    ok 157, $count == 0 ;
489
 
 
490
 
    undef $txn ;
491
 
    undef $cursor ;
492
 
    undef $db1 ;
493
 
    undef $env ;
494
 
    untie %hash ;
495
 
}
496
 
 
497
 
 
498
 
{
499
 
    # DB_DUP
500
 
 
501
 
    my $lex = new LexFile $Dfile ;
502
 
    my %hash ;
503
 
    ok 158, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
504
 
                                      -Property  => DB_DUP,
505
 
                                      -Flags    => DB_CREATE ;
506
 
 
507
 
    $hash{'Wall'} = 'Larry' ;
508
 
    $hash{'Wall'} = 'Stone' ;
509
 
    $hash{'Smith'} = 'John' ;
510
 
    $hash{'Wall'} = 'Brick' ;
511
 
    $hash{'Wall'} = 'Brick' ;
512
 
    $hash{'mouse'} = 'mickey' ;
513
 
 
514
 
    ok 159, keys %hash == 6 ;
515
 
 
516
 
    # create a cursor
517
 
    ok 160, my $cursor = $db->db_cursor() ;
518
 
 
519
 
    my $key = "Wall" ;
520
 
    my $value ;
521
 
    ok 161, $cursor->c_get($key, $value, DB_SET) == 0 ;
522
 
    ok 162, $key eq "Wall" && $value eq "Larry" ;
523
 
    ok 163, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
524
 
    ok 164, $key eq "Wall" && $value eq "Stone" ;
525
 
    ok 165, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
526
 
    ok 166, $key eq "Wall" && $value eq "Brick" ;
527
 
    ok 167, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
528
 
    ok 168, $key eq "Wall" && $value eq "Brick" ;
529
 
 
530
 
    #my $ref = $db->db_stat() ; 
531
 
    #ok 143, $ref->{bt_flags} | DB_DUP ;
532
 
 
533
 
    # test DB_DUP_NEXT
534
 
    my ($k, $v) = ("Wall", "") ;
535
 
    ok 169, $cursor->c_get($k, $v, DB_SET) == 0 ;
536
 
    ok 170, $k eq "Wall" && $v eq "Larry" ;
537
 
    ok 171, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
538
 
    ok 172, $k eq "Wall" && $v eq "Stone" ;
539
 
    ok 173, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
540
 
    ok 174, $k eq "Wall" && $v eq "Brick" ;
541
 
    ok 175, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
542
 
    ok 176, $k eq "Wall" && $v eq "Brick" ;
543
 
    ok 177, $cursor->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
544
 
    
545
 
 
546
 
    undef $db ;
547
 
    undef $cursor ;
548
 
    untie %hash ;
549
 
 
550
 
}
551
 
 
552
 
{
553
 
    # DB_DUP & DupCompare
554
 
    my $lex = new LexFile $Dfile, $Dfile2;
555
 
    my ($key, $value) ;
556
 
    my (%h, %g) ;
557
 
    my @Keys   = qw( 0123 9 12 -1234 9 987654321 9 def  ) ; 
558
 
    my @Values = qw( 1    11 3   dd   x abc      2 0    ) ; 
559
 
 
560
 
    ok 178, tie %h, "BerkeleyDB::Hash", -Filename => $Dfile, 
561
 
                                     -DupCompare   => sub { $_[0] cmp $_[1] },
562
 
                                     -Property  => DB_DUP|DB_DUPSORT,
563
 
                                     -Flags    => DB_CREATE ;
564
 
 
565
 
    ok 179, tie %g, 'BerkeleyDB::Hash', -Filename => $Dfile2, 
566
 
                                     -DupCompare   => sub { $_[0] <=> $_[1] },
567
 
                                     -Property  => DB_DUP|DB_DUPSORT,
568
 
                                     -Flags    => DB_CREATE ;
569
 
 
570
 
    foreach (@Keys) {
571
 
        local $^W = 0 ;
572
 
        my $value = shift @Values ;
573
 
        $h{$_} = $value ; 
574
 
        $g{$_} = $value ;
575
 
    }
576
 
 
577
 
    ok 180, my $cursor = (tied %h)->db_cursor() ;
578
 
    $key = 9 ; $value = "";
579
 
    ok 181, $cursor->c_get($key, $value, DB_SET) == 0 ;
580
 
    ok 182, $key == 9 && $value eq 11 ;
581
 
    ok 183, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
582
 
    ok 184, $key == 9 && $value == 2 ;
583
 
    ok 185, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
584
 
    ok 186, $key == 9 && $value eq "x" ;
585
 
 
586
 
    $cursor = (tied %g)->db_cursor() ;
587
 
    $key = 9 ;
588
 
    ok 187, $cursor->c_get($key, $value, DB_SET) == 0 ;
589
 
    ok 188, $key == 9 && $value eq "x" ;
590
 
    ok 189, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
591
 
    ok 190, $key == 9 && $value == 2 ;
592
 
    ok 191, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
593
 
    ok 192, $key == 9 && $value  == 11 ;
594
 
 
595
 
 
596
 
}
597
 
 
598
 
{
599
 
    # get_dup etc
600
 
    my $lex = new LexFile $Dfile;
601
 
    my %hh ;
602
 
 
603
 
    ok 193, my $YY = tie %hh, "BerkeleyDB::Hash", -Filename => $Dfile, 
604
 
                                     -DupCompare   => sub { $_[0] cmp $_[1] },
605
 
                                     -Property  => DB_DUP,
606
 
                                     -Flags    => DB_CREATE ;
607
 
 
608
 
    $hh{'Wall'} = 'Larry' ;
609
 
    $hh{'Wall'} = 'Stone' ; # Note the duplicate key
610
 
    $hh{'Wall'} = 'Brick' ; # Note the duplicate key
611
 
    $hh{'Smith'} = 'John' ;
612
 
    $hh{'mouse'} = 'mickey' ;
613
 
    
614
 
    # first work in scalar context
615
 
    ok 194, scalar $YY->get_dup('Unknown') == 0 ;
616
 
    ok 195, scalar $YY->get_dup('Smith') == 1 ;
617
 
    ok 196, scalar $YY->get_dup('Wall') == 3 ;
618
 
    
619
 
    # now in list context
620
 
    my @unknown = $YY->get_dup('Unknown') ;
621
 
    ok 197, "@unknown" eq "" ;
622
 
    
623
 
    my @smith = $YY->get_dup('Smith') ;
624
 
    ok 198, "@smith" eq "John" ;
625
 
    
626
 
    {
627
 
        my @wall = $YY->get_dup('Wall') ;
628
 
        my %wall ;
629
 
        @wall{@wall} = @wall ;
630
 
        ok 199, (@wall == 3 && $wall{'Larry'} 
631
 
                        && $wall{'Stone'} && $wall{'Brick'});
632
 
    }
633
 
    
634
 
    # hash
635
 
    my %unknown = $YY->get_dup('Unknown', 1) ;
636
 
    ok 200, keys %unknown == 0 ;
637
 
    
638
 
    my %smith = $YY->get_dup('Smith', 1) ;
639
 
    ok 201, keys %smith == 1 && $smith{'John'} ;
640
 
    
641
 
    my %wall = $YY->get_dup('Wall', 1) ;
642
 
    ok 202, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 
643
 
                && $wall{'Brick'} == 1 ;
644
 
    
645
 
    undef $YY ;
646
 
    untie %hh ;
647
 
 
648
 
}
649
 
 
650
 
{
651
 
   # sub-class test
652
 
 
653
 
   package Another ;
654
 
 
655
 
   use strict ;
656
 
 
657
 
   open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
658
 
   print FILE <<'EOM' ;
659
 
 
660
 
   package SubDB ;
661
 
 
662
 
   use strict ;
663
 
   use vars qw( @ISA @EXPORT) ;
664
 
 
665
 
   require Exporter ;
666
 
   use BerkeleyDB;
667
 
   @ISA=qw(BerkeleyDB::Hash);
668
 
   @EXPORT = @BerkeleyDB::EXPORT ;
669
 
 
670
 
   sub db_put { 
671
 
        my $self = shift ;
672
 
        my $key = shift ;
673
 
        my $value = shift ;
674
 
        $self->SUPER::db_put($key, $value * 3) ;
675
 
   }
676
 
 
677
 
   sub db_get { 
678
 
        my $self = shift ;
679
 
        $self->SUPER::db_get($_[0], $_[1]) ;
680
 
        $_[1] -= 2 ;
681
 
   }
682
 
 
683
 
   sub A_new_method
684
 
   {
685
 
        my $self = shift ;
686
 
        my $key = shift ;
687
 
        my $value = $self->FETCH($key) ;
688
 
        return "[[$value]]" ;
689
 
   }
690
 
 
691
 
   1 ;
692
 
EOM
693
 
 
694
 
    close FILE ;
695
 
 
696
 
    BEGIN { push @INC, '.'; }    
697
 
    eval 'use SubDB ; ';
698
 
    main::ok 203, $@ eq "" ;
699
 
    my %h ;
700
 
    my $X ;
701
 
    eval '
702
 
        $X = tie(%h, "SubDB", -Filename => "dbhash.tmp", 
703
 
                        -Flags => DB_CREATE,
704
 
                        -Mode => 0640 );
705
 
        ' ;
706
 
 
707
 
    main::ok 204, $@ eq "" ;
708
 
 
709
 
    my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
710
 
    main::ok 205, $@ eq "" ;
711
 
    main::ok 206, $ret == 7 ;
712
 
 
713
 
    my $value = 0;
714
 
    $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ;
715
 
    main::ok 207, $@ eq "" ;
716
 
    main::ok 208, $ret == 10 ;
717
 
 
718
 
    $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
719
 
    main::ok 209, $@ eq ""  ;
720
 
    main::ok 210, $ret == 1 ;
721
 
 
722
 
    $ret = eval '$X->A_new_method("joe") ' ;
723
 
    main::ok 211, $@ eq "" ;
724
 
    main::ok 212, $ret eq "[[10]]" ;
725
 
 
726
 
    unlink "SubDB.pm", "dbhash.tmp" ;
727
 
 
728
 
}