8
unless(grep /blib/, @INC) {
10
@INC = '../lib' if -d '../lib';
19
if ($BerkeleyDB::db_version < 3.3) {
20
print "1..0 # Skipping test, Queue needs Berkeley DB 3.3.x or better\n" ;
31
my $pad = shift || " " ;
32
my $template = $pad x $length ;
33
substr($template, 0, length($var)) = $var ;
37
my $Dfile = "dbhash.tmp";
38
my $Dfile2 = "dbhash2.tmp";
39
my $Dfile3 = "dbhash3.tmp";
45
# Check for invalid parameters
47
# Check for invalid parameters
49
eval ' $db = new BerkeleyDB::Queue -Stupid => 3 ; ' ;
50
ok 1, $@ =~ /unknown key value\(s\) Stupid/ ;
52
eval ' $db = new BerkeleyDB::Queue -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
53
ok 2, $@ =~ /unknown key value\(s\) / ;
55
eval ' $db = new BerkeleyDB::Queue -Env => 2 ' ;
56
ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
58
eval ' $db = new BerkeleyDB::Queue -Txn => "x" ' ;
59
ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
61
my $obj = bless [], "main" ;
62
eval ' $db = new BerkeleyDB::Queue -Env => $obj ' ;
63
ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
66
# Now check the interface to Queue
69
my $lex = new LexFile $Dfile ;
73
ok 6, my $db = new BerkeleyDB::Queue -Filename => $Dfile,
81
ok 7, $db->db_put(1, "some value") == 0 ;
82
ok 8, $db->status() == 0 ;
83
ok 9, $db->db_get(1, $value) == 0 ;
84
ok 10, $value eq fillout("some value", $rec_len, $pad) ;
85
ok 11, $db->db_put(2, "value") == 0 ;
86
ok 12, $db->db_get(2, $value) == 0 ;
87
ok 13, $value eq fillout("value", $rec_len, $pad) ;
88
ok 14, $db->db_del(1) == 0 ;
89
ok 15, ($status = $db->db_get(1, $value)) == DB_KEYEMPTY ;
90
ok 16, $db->status() == DB_KEYEMPTY ;
91
ok 17, $db->status() eq $DB_errors{'DB_KEYEMPTY'} ;
93
ok 18, ($status = $db->db_get(7, $value)) == DB_NOTFOUND ;
94
ok 19, $db->status() == DB_NOTFOUND ;
95
ok 20, $db->status() eq $DB_errors{'DB_NOTFOUND'} ;
97
ok 21, $db->db_sync() == 0 ;
99
# Check NOOVERWRITE will make put fail when attempting to overwrite
100
# an existing record.
102
ok 22, $db->db_put( 2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
103
ok 23, $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
104
ok 24, $db->status() == DB_KEYEXIST ;
107
# check that the value of the key has not been changed by the
109
ok 25, $db->db_get(2, $value) == 0 ;
110
ok 26, $value eq fillout("value", $rec_len, $pad) ;
117
# Check simple env works with a array.
118
# and pad defaults to space
119
my $lex = new LexFile $Dfile ;
121
my $home = "./fred" ;
123
ok 27, my $lexD = new LexDir($home);
125
ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,
127
ok 29, my $db = new BerkeleyDB::Queue -Filename => $Dfile,
134
ok 30, $db->db_put(1, "some value") == 0 ;
135
ok 31, $db->db_get(1, $value) == 0 ;
136
ok 32, $value eq fillout("some value", $rec_len) ;
145
my $lex = new LexFile $Dfile ;
149
ok 33, my $db = new BerkeleyDB::Queue -Filename => $Dfile,
151
-Flags => DB_CREATE ,
164
for ($i = 0 ; $i < @data ; ++$i) {
165
$ret += $db->db_put($i, $data[$i]) ;
166
$data{$i} = $data[$i] ;
171
ok 35, my $cursor = $db->db_cursor() ;
177
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
179
if ( fillout($copy{$k}, $rec_len) eq $v )
185
ok 36, $cursor->status() == DB_NOTFOUND ;
186
ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
187
ok 38, keys %copy == 0 ;
188
ok 39, $extras == 0 ;
194
for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
196
$status = $cursor->c_get($k, $v, DB_PREV)) {
197
if ( fillout($copy{$k}, $rec_len) eq $v )
202
ok 40, $status == DB_NOTFOUND ;
203
ok 41, $status eq $DB_errors{'DB_NOTFOUND'} ;
204
ok 42, $cursor->status() == $status ;
205
ok 43, $cursor->status() eq $status ;
206
ok 44, keys %copy == 0 ;
207
ok 45, $extras == 0 ;
211
# Tied Array interface
213
my $lex = new LexFile $Dfile ;
217
ok 46, $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile,
219
-Flags => DB_CREATE ,
222
ok 47, my $cursor = (tied @array)->db_cursor() ;
223
# check the database is empty
225
my ($k, $v) = (0,"") ;
226
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
229
ok 48, $cursor->status() == DB_NOTFOUND ;
236
$array[1] = "some value";
237
ok 51, (tied @array)->status() == 0 ;
238
ok 52, $array[1] eq fillout("some value", $rec_len);
239
ok 53, defined $array[1];
240
ok 54, (tied @array)->status() == 0 ;
241
ok 55, !defined $array[3];
242
ok 56, (tied @array)->status() == DB_NOTFOUND ;
244
ok 57, (tied @array)->db_del(1) == 0 ;
245
ok 58, (tied @array)->status() == 0 ;
246
ok 59, ! defined $array[1];
247
ok 60, (tied @array)->status() == DB_KEYEMPTY ;
251
$array[1000] = 2000 ;
253
my ($keys, $values) = (0,0);
255
for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
257
$status = $cursor->c_get($k, $v, DB_NEXT)) {
263
ok 62, $keys == 1011 ;
264
ok 63, $values == 2022 ;
266
# unshift isn't allowed
268
# $FA ? unshift @array, "red", "green", "blue"
269
# : $db->unshift("red", "green", "blue" ) ;
271
# ok 64, $@ =~ /^unshift is unsupported with Queue databases/ ;
273
$array[1] = "green" ;
276
ok 64, $array[0] eq fillout("red", $rec_len) ;
277
ok 65, $cursor->c_get($k, $v, DB_FIRST) == 0 ;
279
ok 67, $v eq fillout("red", $rec_len) ;
280
ok 68, $array[1] eq fillout("green", $rec_len) ;
281
ok 69, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
283
ok 71, $v eq fillout("green", $rec_len) ;
284
ok 72, $array[2] eq fillout("blue", $rec_len) ;
285
ok 73, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
287
ok 75, $v eq fillout("blue", $rec_len) ;
288
ok 76, $array[4] == 2 ;
289
ok 77, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
294
ok 80, ($FA ? shift @array : $db->shift()) eq fillout("red", $rec_len) ;
295
ok 81, ($FA ? shift @array : $db->shift()) eq fillout("green", $rec_len) ;
296
ok 82, ($FA ? shift @array : $db->shift()) eq fillout("blue", $rec_len) ;
297
ok 83, ($FA ? shift @array : $db->shift()) == 2 ;
300
$FA ? push @array, "the", "end"
301
: $db->push("the", "end") ;
302
ok 84, $cursor->c_get($k, $v, DB_LAST) == 0 ;
304
ok 86, $v eq fillout("end", $rec_len) ;
305
ok 87, $cursor->c_get($k, $v, DB_PREV) == 0 ;
307
ok 89, $v eq fillout("the", $rec_len) ;
308
ok 90, $cursor->c_get($k, $v, DB_PREV) == 0 ;
313
ok 93, ( $FA ? pop @array : $db->pop ) eq fillout("end", $rec_len) ;
314
ok 94, ( $FA ? pop @array : $db->pop ) eq fillout("the", $rec_len) ;
315
ok 95, ( $FA ? pop @array : $db->pop ) == 2000 ;
317
# now clear the array
320
ok 96, $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
334
ok 97, my $db = tie @array, 'BerkeleyDB::Queue',
337
ok 98, $db->db_put(1, "some value") == 0 ;
338
ok 99, $db->db_get(1, $value) == 0 ;
339
ok 100, $value eq fillout("some value", $rec_len) ;
345
# check works via API
347
my $lex = new LexFile $Dfile ;
350
ok 101, my $db = new BerkeleyDB::Queue -Filename => $Dfile,
351
-Flags => DB_CREATE ,
365
for ($i = 0 ; $i < @data ; ++$i) {
366
my $r = $db->db_put($i, $data[$i]) ;
372
my ($pon, $off, $len) = $db->partial_set(0,2) ;
373
ok 103, ! $pon && $off == 0 && $len == 0 ;
374
ok 104, $db->db_get(1, $value) == 0 && $value eq "bo" ;
375
ok 105, $db->db_get(2, $value) == 0 && $value eq "ho" ;
376
ok 106, $db->db_get(3, $value) == 0 && $value eq "se" ;
378
# do a partial get, off end of data
379
($pon, $off, $len) = $db->partial_set(3,2) ;
383
ok 110, $db->db_get(1, $value) == 0 && $value eq fillout("t", 2) ;
384
ok 111, $db->db_get(2, $value) == 0 && $value eq "se" ;
385
ok 112, $db->db_get(3, $value) == 0 && $value eq " " ;
387
# switch of partial mode
388
($pon, $off, $len) = $db->partial_clear() ;
392
ok 116, $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ;
393
ok 117, $db->db_get(2, $value) == 0 && $value eq fillout("house", $rec_len) ;
394
ok 118, $db->db_get(3, $value) == 0 && $value eq fillout("sea", $rec_len) ;
397
$db->partial_set(0,2) ;
398
ok 119, $db->db_put(1, "") != 0 ;
399
ok 120, $db->db_put(2, "AB") == 0 ;
400
ok 121, $db->db_put(3, "XY") == 0 ;
401
ok 122, $db->db_put(4, "KLM") != 0 ;
402
ok 123, $db->db_put(4, "KL") == 0 ;
404
($pon, $off, $len) = $db->partial_clear() ;
408
ok 127, $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ;
409
ok 128, $db->db_get(2, $value) == 0 && $value eq fillout("ABuse", $rec_len) ;
410
ok 129, $db->db_get(3, $value) == 0 && $value eq fillout("XYa", $rec_len) ;
411
ok 130, $db->db_get(4, $value) == 0 && $value eq fillout("KL", $rec_len) ;
414
($pon, $off, $len) = $db->partial_set(3,2) ;
418
ok 134, $db->db_put(1, "PP") == 0 ;
419
ok 135, $db->db_put(2, "Q") != 0 ;
420
ok 136, $db->db_put(3, "XY") == 0 ;
421
ok 137, $db->db_put(4, "TU") == 0 ;
423
$db->partial_clear() ;
424
ok 138, $db->db_get(1, $value) == 0 && $value eq fillout("boaPP", $rec_len) ;
425
ok 139, $db->db_get(2, $value) == 0 && $value eq fillout("ABuse",$rec_len) ;
426
ok 140, $db->db_get(3, $value) == 0 && $value eq fillout("XYaXY", $rec_len) ;
427
ok 141, $db->db_get(4, $value) == 0 && $value eq fillout("KL TU", $rec_len) ;
432
# check works via tied array
434
my $lex = new LexFile $Dfile ;
438
ok 142, my $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile,
439
-Flags => DB_CREATE ,
453
for ($i = 1 ; $i < @data ; ++$i) {
454
$array[$i] = $data[$i] ;
455
$status += $db->status() ;
458
ok 143, $status == 0 ;
461
$db->partial_set(0,2) ;
462
ok 144, $array[1] eq fillout("bo", 2) ;
463
ok 145, $array[2] eq fillout("ho", 2) ;
464
ok 146, $array[3] eq fillout("se", 2) ;
466
# do a partial get, off end of data
467
$db->partial_set(3,2) ;
468
ok 147, $array[1] eq fillout("t", 2) ;
469
ok 148, $array[2] eq fillout("se", 2) ;
470
ok 149, $array[3] eq fillout("", 2) ;
472
# switch of partial mode
473
$db->partial_clear() ;
474
ok 150, $array[1] eq fillout("boat", $rec_len) ;
475
ok 151, $array[2] eq fillout("house", $rec_len) ;
476
ok 152, $array[3] eq fillout("sea", $rec_len) ;
479
$db->partial_set(0,2) ;
481
ok 153, $db->status() != 0 ;
483
ok 154, $db->status() == 0 ;
485
ok 155, $db->status() == 0 ;
487
ok 156, $db->status() == 0 ;
489
$db->partial_clear() ;
490
ok 157, $array[1] eq fillout("boat", $rec_len) ;
491
ok 158, $array[2] eq fillout("ABuse", $rec_len) ;
492
ok 159, $array[3] eq fillout("XYa", $rec_len) ;
493
ok 160, $array[4] eq fillout("KL", $rec_len) ;
496
$db->partial_set(3,2) ;
498
ok 161, $db->status() == 0 ;
500
ok 162, $db->status() != 0 ;
502
ok 163, $db->status() == 0 ;
504
ok 164, $db->status() == 0 ;
506
$db->partial_clear() ;
507
ok 165, $array[1] eq fillout("boaPP", $rec_len) ;
508
ok 166, $array[2] eq fillout("ABuse", $rec_len) ;
509
ok 167, $array[3] eq fillout("XYaXY", $rec_len) ;
510
ok 168, $array[4] eq fillout("KL TU", $rec_len) ;
516
my $lex = new LexFile $Dfile ;
520
my $home = "./fred" ;
521
ok 169, my $lexD = new LexDir($home);
523
ok 170, my $env = new BerkeleyDB::Env -Home => $home,
524
-Flags => DB_CREATE|DB_INIT_TXN|
525
DB_INIT_MPOOL|DB_INIT_LOCK ;
526
ok 171, my $txn = $env->txn_begin() ;
527
ok 172, my $db1 = tie @array, 'BerkeleyDB::Queue',
530
-Flags => DB_CREATE ,
537
ok 173, $txn->txn_commit() == 0 ;
538
ok 174, $txn = $env->txn_begin() ;
550
for ($i = 0 ; $i < @data ; ++$i) {
551
$ret += $db1->db_put($i, $data[$i]) ;
555
# should be able to see all the records
557
ok 176, my $cursor = $db1->db_cursor() ;
558
my ($k, $v) = (0, "") ;
561
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
564
ok 177, $count == 3 ;
567
# now abort the transaction
568
ok 178, $txn->txn_abort() == 0 ;
570
# there shouldn't be any records in the database
573
ok 179, $cursor = $db1->db_cursor() ;
574
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
577
ok 180, $count == 0 ;
590
my $lex = new LexFile $Dfile ;
591
my $recs = ($BerkeleyDB::db_version >= 3.1 ? "qs_ndata" : "qs_nrecs") ;
595
ok 181, my $db = new BerkeleyDB::Queue -Filename => $Dfile,
597
-Pagesize => 4 * 1024,
602
my $ref = $db->db_stat() ;
603
ok 182, $ref->{$recs} == 0;
604
ok 183, $ref->{'qs_pagesize'} == 4 * 1024;
615
for ($i = $db->ArrayOffset ; @data ; ++$i) {
616
$ret += $db->db_put($i, shift @data) ;
620
$ref = $db->db_stat() ;
621
ok 185, $ref->{$recs} == 3;
631
open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
637
use vars qw( @ISA @EXPORT) ;
641
@ISA=qw(BerkeleyDB::Queue);
642
@EXPORT = @BerkeleyDB::EXPORT ;
648
$self->SUPER::db_put($key, $value * 3) ;
653
$self->SUPER::db_get($_[0], $_[1]) ;
661
my $value = $self->FETCH($key) ;
662
return "[[$value]]" ;
670
BEGIN { push @INC, '.'; }
672
main::ok 186, $@ eq "" ;
677
$X = tie(@h, "SubDB", -Filename => "dbqueue.tmp",
685
main::ok 187, $@ eq "" ;
687
my $ret = eval '$h[1] = 3 ; return $h[1] ' ;
688
main::ok 188, $@ eq "" ;
689
main::ok 189, $ret == 7 ;
692
$ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ;
693
main::ok 190, $@ eq "" ;
694
main::ok 191, $ret == 10 ;
696
$ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
697
main::ok 192, $@ eq "" ;
698
main::ok 193, $ret == 1 ;
700
$ret = eval '$X->A_new_method(1) ' ;
701
main::ok 194, $@ eq "" ;
702
main::ok 195, $ret eq "[[10]]" ;
706
unlink "SubDB.pm", "dbqueue.tmp" ;
713
my $lex = new LexFile $Dfile;
717
ok 196, my $db = tie @array, 'BerkeleyDB::Queue',
719
-Flags => DB_CREATE ,
723
# create a few records
728
ok 197, $db->db_put($k, "fred", DB_APPEND) == 0 ;
730
ok 199, $array[4] eq fillout("fred", $rec_len) ;
737
# 23 Sept 2001 -- push into an empty array
738
my $lex = new LexFile $Dfile ;
742
ok 200, $db = tie @array, 'BerkeleyDB::Queue',
743
-Flags => DB_CREATE ,
747
-Filename => $Dfile ;
748
$FA ? push @array, "first"
749
: $db->push("first") ;
751
ok 201, ($FA ? pop @array : $db->pop()) eq fillout("first", $rec_len) ;
763
# DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records