1#!./perl -w
2
3# ID: %I%, %G%   
4
5use strict ;
6
7use lib 't' ;
8use BerkeleyDB; 
9use Test::More;
10use util(1) ;
11
12plan(skip_all => "Queue needs Berkeley DB 3.3.x or better\n" )
13    if $BerkeleyDB::db_version < 3.3;
14    
15plan tests => 253;
16
17
18my $Dfile = "dbhash.tmp";
19my $Dfile2 = "dbhash2.tmp";
20my $Dfile3 = "dbhash3.tmp";
21unlink $Dfile;
22
23umask(0) ;
24
25
26# Check for invalid parameters
27{
28    # Check for invalid parameters
29    my $db ;
30    eval ' $db = new BerkeleyDB::Queue  -Stupid => 3 ; ' ;
31    ok $@ =~ /unknown key value\(s\) Stupid/  ;
32
33    eval ' $db = new BerkeleyDB::Queue -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
34    ok $@ =~ /unknown key value\(s\) /  ;
35
36    eval ' $db = new BerkeleyDB::Queue -Env => 2 ' ;
37    ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
38
39    eval ' $db = new BerkeleyDB::Queue -Txn => "x" ' ;
40    ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
41
42    my $obj = bless [], "main" ;
43    eval ' $db = new BerkeleyDB::Queue -Env => $obj ' ;
44    ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
45}
46
47# Now check the interface to Queue
48
49{
50    my $lex = new LexFile $Dfile ;
51    my $rec_len = 10 ;
52    my $pad = "x" ;
53
54    ok my $db = new BerkeleyDB::Queue -Filename => $Dfile, 
55				    -Flags    => DB_CREATE,
56				    -Len      => $rec_len,
57				    -Pad      => $pad;
58
59    # Add a k/v pair
60    my $value ;
61    my $status ;
62    ok $db->db_put(1, "some value") == 0  ;
63    ok $db->status() == 0 ;
64    ok $db->db_get(1, $value) == 0 ;
65    ok $value eq fillout("some value", $rec_len, $pad) ;
66    ok $db->db_put(2, "value") == 0  ;
67    ok $db->db_get(2, $value) == 0 ;
68    ok $value eq fillout("value", $rec_len, $pad) ;
69    ok $db->db_put(3, "value") == 0  ;
70    ok $db->db_get(3, $value) == 0 ;
71    ok $value eq fillout("value", $rec_len, $pad) ;
72    ok $db->db_del(2) == 0 ;
73    ok $db->db_get(2, $value) == DB_KEYEMPTY ;
74    ok $db->status() == DB_KEYEMPTY ;
75    ok $db->status() eq $DB_errors{'DB_KEYEMPTY'} ;
76
77    ok $db->db_get(7, $value) == DB_NOTFOUND ;
78    ok $db->status() == DB_NOTFOUND ;
79    ok $db->status() eq $DB_errors{'DB_NOTFOUND'} ;
80
81    ok $db->db_sync() == 0 ;
82
83    # Check NOOVERWRITE will make put fail when attempting to overwrite
84    # an existing record.
85
86    ok $db->db_put( 1, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
87    ok $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
88    ok $db->status() == DB_KEYEXIST ;
89
90
91    # check that the value of the key  has not been changed by the
92    # previous test
93    ok $db->db_get(1, $value) == 0 ;
94    ok $value eq fillout("some value", $rec_len, $pad) ;
95
96
97}
98
99
100{
101    # Check simple env works with a array.
102    # and pad defaults to space
103    my $lex = new LexFile $Dfile ;
104
105    my $home = "./fred" ;
106    my $rec_len = 11 ;
107    ok my $lexD = new LexDir($home);
108
109    ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,@StdErrFile,
110    					 -Home => $home ;
111    ok my $db = new BerkeleyDB::Queue -Filename => $Dfile, 
112				    -Env      => $env,
113				    -Flags    => DB_CREATE,
114				    -Len      => $rec_len;
115
116    # Add a k/v pair
117    my $value ;
118    ok $db->db_put(1, "some value") == 0 ;
119    ok $db->db_get(1, $value) == 0 ;
120    ok $value eq fillout("some value", $rec_len)  ;
121    undef $db ;
122    undef $env ;
123}
124
125 
126{
127    # cursors
128
129    my $lex = new LexFile $Dfile ;
130    my @array ;
131    my ($k, $v) ;
132    my $rec_len = 5 ;
133    ok my $db = new BerkeleyDB::Queue -Filename  => $Dfile, 
134				    	  -ArrayBase => 0,
135				    	  -Flags     => DB_CREATE ,
136				    	  -Len       => $rec_len;
137
138    # create some data
139    my @data =  (
140		"red"	,
141		"green"	,
142		"blue"	,
143		) ;
144
145    my $i ;
146    my %data ;
147    my $ret = 0 ;
148    for ($i = 0 ; $i < @data ; ++$i) {
149        $ret += $db->db_put($i, $data[$i]) ;
150	$data{$i} = $data[$i] ;
151    }
152    ok $ret == 0 ;
153
154    # create the cursor
155    ok my $cursor = $db->db_cursor() ;
156
157    $k = 0 ; $v = "" ;
158    my %copy = %data;
159    my $extras = 0 ;
160    # sequence forwards
161    while ($cursor->c_get($k, $v, DB_NEXT) == 0) 
162    {
163        if ( fillout($copy{$k}, $rec_len) eq $v ) 
164            { delete $copy{$k} }
165	else
166	    { ++ $extras }
167    }
168
169    ok $cursor->status() == DB_NOTFOUND ;
170    ok $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
171    ok keys %copy == 0 ;
172    ok $extras == 0 ;
173
174    # sequence backwards
175    %copy = %data ;
176    $extras = 0 ;
177    my $status ;
178    for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
179	  $status == 0 ;
180    	  $status = $cursor->c_get($k, $v, DB_PREV)) {
181        if ( fillout($copy{$k}, $rec_len) eq $v ) 
182            { delete $copy{$k} }
183	else
184	    { ++ $extras }
185    }
186    ok $status == DB_NOTFOUND ;
187    ok $status eq $DB_errors{'DB_NOTFOUND'} ;
188    ok $cursor->status() == $status ;
189    ok $cursor->status() eq $status ;
190    ok keys %copy == 0 ;
191    ok $extras == 0 ;
192}
193 
194{
195    # Tied Array interface
196
197    my $lex = new LexFile $Dfile ;
198    my @array ;
199    my $db ;
200    my $rec_len = 10 ;
201    ok $db = tie @array, 'BerkeleyDB::Queue', -Filename  => $Dfile,
202				    	    -ArrayBase => 0,
203                                            -Flags     => DB_CREATE ,
204				    	    -Len       => $rec_len;
205
206    ok my $cursor = (tied @array)->db_cursor() ;
207    # check the database is empty
208    my $count = 0 ;
209    my ($k, $v) = (0,"") ;
210    while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
211	++ $count ;
212    }
213    ok $cursor->status() == DB_NOTFOUND ;
214    ok $count == 0 ;
215
216    ok @array == 0 ;
217
218    # Add a k/v pair
219    my $value ;
220    $array[1] = "some value";
221    ok ((tied @array)->status() == 0) ;
222    ok $array[1] eq fillout("some value", $rec_len);
223    ok defined $array[1];
224    ok ((tied @array)->status() == 0) ;
225    ok !defined $array[3];
226    ok ((tied @array)->status() == DB_NOTFOUND) ;
227
228    $array[1] = 2 ;
229    $array[10] = 20 ;
230    $array[100] = 200 ;
231
232    my ($keys, $values) = (0,0);
233    $count = 0 ;
234    for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
235	  $status == 0 ;
236    	  $status = $cursor->c_get($k, $v, DB_NEXT)) {
237        $keys += $k ;
238	$values += $v ;
239	++ $count ;
240    }
241    ok $count == 3 ;
242    ok $keys == 111 ;
243    ok $values == 222 ;
244
245    # unshift isn't allowed
246#    eval {
247#    	$FA ? unshift @array, "red", "green", "blue" 
248#        : $db->unshift("red", "green", "blue" ) ;
249#	} ;
250#    ok $@ =~ /^unshift is unsupported with Queue databases/ ;	
251    $array[0] = "red" ;
252    $array[1] = "green" ;
253    $array[2] = "blue" ;
254    $array[4] = 2 ;
255    ok $array[0] eq fillout("red", $rec_len) ;
256    ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;
257    ok $k == 0 ;
258    ok $v eq fillout("red", $rec_len) ;
259    ok $array[1] eq fillout("green", $rec_len) ;
260    ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
261    ok $k == 1 ;
262    ok $v eq fillout("green", $rec_len) ;
263    ok $array[2] eq fillout("blue", $rec_len) ;
264    ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
265    ok $k == 2 ;
266    ok $v eq fillout("blue", $rec_len) ;
267    ok $array[4] == 2 ;
268    ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
269    ok $k == 4 ;
270    ok $v == 2 ;
271
272    # shift
273    ok (($FA ? shift @array : $db->shift()) eq fillout("red", $rec_len)) ;
274    ok (($FA ? shift @array : $db->shift()) eq fillout("green", $rec_len)) ;
275    ok (($FA ? shift @array : $db->shift()) eq fillout("blue", $rec_len)) ;
276    ok (($FA ? shift @array : $db->shift()) == 2) ;
277
278    # push
279    $FA ? push @array, "the", "end" 
280        : $db->push("the", "end") ;
281    ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
282    ok $k == 102 ;
283    ok $v eq fillout("end", $rec_len) ;
284    ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
285    ok $k == 101 ;
286    ok $v eq fillout("the", $rec_len) ;
287    ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
288    ok $k == 100 ;
289    ok $v == 200 ;
290
291    # pop
292    ok (( $FA ? pop @array : $db->pop ) eq fillout("end", $rec_len)) ;
293    ok (( $FA ? pop @array : $db->pop ) eq fillout("the", $rec_len)) ;
294    ok (( $FA ? pop @array : $db->pop ) == 200)  ;
295
296    # now clear the array 
297    $FA ? @array = () 
298        : $db->clear() ;
299    ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
300
301    undef $cursor ;
302    undef $db ;
303    untie @array ;
304}
305
306{
307    # in-memory file
308
309    my @array ;
310    my $fd ;
311    my $value ;
312    my $rec_len = 15 ;
313    ok my $db = tie @array, 'BerkeleyDB::Queue',
314				    	    -Len       => $rec_len;
315
316    ok $db->db_put(1, "some value") == 0  ;
317    ok $db->db_get(1, $value) == 0 ;
318    ok $value eq fillout("some value", $rec_len) ;
319
320}
321 
322{
323    # partial
324    # check works via API
325
326    my $lex = new LexFile $Dfile ;
327    my $value ;
328    my $rec_len = 8 ;
329    ok my $db = new BerkeleyDB::Queue  -Filename => $Dfile,
330                                      	    -Flags    => DB_CREATE ,
331				    	    -Len      => $rec_len,
332				    	    -Pad      => " " ;
333
334    # create some data
335    my @data =  (
336		"",
337		"boat",
338		"house",
339		"sea",
340		) ;
341
342    my $ret = 0 ;
343    my $i ;
344    for ($i = 0 ; $i < @data ; ++$i) {
345        my $r = $db->db_put($i, $data[$i]) ;
346        $ret += $r ;
347    }
348    ok $ret == 0 ;
349
350    # do a partial get
351    my ($pon, $off, $len) = $db->partial_set(0,2) ;
352    ok ! $pon && $off == 0 && $len == 0 ;
353    ok $db->db_get(1, $value) == 0 && $value eq "bo" ;
354    ok $db->db_get(2, $value) == 0 && $value eq "ho" ;
355    ok $db->db_get(3, $value) == 0 && $value eq "se" ;
356
357    # do a partial get, off end of data
358    ($pon, $off, $len) = $db->partial_set(3,2) ;
359    ok $pon ;
360    ok $off == 0 ;
361    ok $len == 2 ;
362    ok $db->db_get(1, $value) == 0 && $value eq fillout("t", 2) ;
363    ok $db->db_get(2, $value) == 0 && $value eq "se" ;
364    ok $db->db_get(3, $value) == 0 && $value eq "  " ;
365
366    # switch of partial mode
367    ($pon, $off, $len) = $db->partial_clear() ;
368    ok $pon ;
369    ok $off == 3 ;
370    ok $len == 2 ;
371    ok $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ;
372    ok $db->db_get(2, $value) == 0 && $value eq fillout("house", $rec_len) ;
373    ok $db->db_get(3, $value) == 0 && $value eq fillout("sea", $rec_len) ;
374
375    # now partial put
376    $db->partial_set(0,2) ;
377    ok $db->db_put(1, "") != 0 ;
378    ok $db->db_put(2, "AB") == 0 ;
379    ok $db->db_put(3, "XY") == 0 ;
380    ok $db->db_put(4, "KLM") != 0 ;
381    ok $db->db_put(4, "KL") == 0 ;
382
383    ($pon, $off, $len) = $db->partial_clear() ;
384    ok $pon ;
385    ok $off == 0 ;
386    ok $len == 2 ;
387    ok $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ;
388    ok $db->db_get(2, $value) == 0 && $value eq fillout("ABuse", $rec_len) ;
389    ok $db->db_get(3, $value) == 0 && $value eq fillout("XYa", $rec_len) ;
390    ok $db->db_get(4, $value) == 0 && $value eq fillout("KL", $rec_len) ;
391
392    # now partial put
393    ($pon, $off, $len) = $db->partial_set(3,2) ;
394    ok ! $pon ;
395    ok $off == 0 ;
396    ok $len == 0 ;
397    ok $db->db_put(1, "PP") == 0 ;
398    ok $db->db_put(2, "Q") != 0 ;
399    ok $db->db_put(3, "XY") == 0 ;
400    ok $db->db_put(4, "TU") == 0 ;
401
402    $db->partial_clear() ;
403    ok $db->db_get(1, $value) == 0 && $value eq fillout("boaPP", $rec_len) ;
404    ok $db->db_get(2, $value) == 0 && $value eq fillout("ABuse",$rec_len) ;
405    ok $db->db_get(3, $value) == 0 && $value eq fillout("XYaXY", $rec_len) ;
406    ok $db->db_get(4, $value) == 0 && $value eq fillout("KL TU", $rec_len) ;
407}
408
409{
410    # partial
411    # check works via tied array 
412
413    my $lex = new LexFile $Dfile ;
414    my @array ;
415    my $value ;
416    my $rec_len = 8 ;
417    ok my $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile,
418                                      	        -Flags    => DB_CREATE ,
419				    	        -Len       => $rec_len,
420				    	        -Pad       => " " ;
421
422    # create some data
423    my @data =  (
424		"",
425		"boat",
426		"house",
427		"sea",
428		) ;
429
430    my $i ;
431    my $status = 0 ;
432    for ($i = 1 ; $i < @data ; ++$i) {
433	$array[$i] = $data[$i] ;
434	$status += $db->status() ;
435    }
436
437    ok $status == 0 ;
438
439    # do a partial get
440    $db->partial_set(0,2) ;
441    ok $array[1] eq fillout("bo", 2) ;
442    ok $array[2] eq fillout("ho", 2) ;
443    ok $array[3]  eq fillout("se", 2) ;
444
445    # do a partial get, off end of data
446    $db->partial_set(3,2) ;
447    ok $array[1] eq fillout("t", 2) ;
448    ok $array[2] eq fillout("se", 2) ;
449    ok $array[3] eq fillout("", 2) ;
450
451    # switch of partial mode
452    $db->partial_clear() ;
453    ok $array[1] eq fillout("boat", $rec_len) ;
454    ok $array[2] eq fillout("house", $rec_len) ;
455    ok $array[3] eq fillout("sea", $rec_len) ;
456
457    # now partial put
458    $db->partial_set(0,2) ;
459    $array[1] = "" ;
460    ok $db->status() != 0 ;
461    $array[2] = "AB" ;
462    ok $db->status() == 0 ;
463    $array[3] = "XY" ;
464    ok $db->status() == 0 ;
465    $array[4] = "KL" ;
466    ok $db->status() == 0 ;
467
468    $db->partial_clear() ;
469    ok $array[1] eq fillout("boat", $rec_len) ;
470    ok $array[2] eq fillout("ABuse", $rec_len) ;
471    ok $array[3] eq fillout("XYa", $rec_len) ;
472    ok $array[4] eq fillout("KL", $rec_len) ;
473
474    # now partial put
475    $db->partial_set(3,2) ;
476    $array[1] = "PP" ;
477    ok $db->status() == 0 ;
478    $array[2] = "Q" ;
479    ok $db->status() != 0 ;
480    $array[3] = "XY" ;
481    ok $db->status() == 0 ;
482    $array[4] = "TU" ;
483    ok $db->status() == 0 ;
484
485    $db->partial_clear() ;
486    ok $array[1] eq fillout("boaPP", $rec_len) ;
487    ok $array[2] eq fillout("ABuse", $rec_len) ;
488    ok $array[3] eq fillout("XYaXY", $rec_len) ;
489    ok $array[4] eq fillout("KL TU", $rec_len) ;
490}
491
492{
493    # transaction
494
495    my $lex = new LexFile $Dfile ;
496    my @array ;
497    my $value ;
498
499    my $home = "./fred" ;
500    ok my $lexD = new LexDir($home);
501    my $rec_len = 9 ;
502    ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
503				     -Flags => DB_CREATE|DB_INIT_TXN|
504					  	DB_INIT_MPOOL|DB_INIT_LOCK ;
505    ok my $txn = $env->txn_begin() ;
506    ok my $db1 = tie @array, 'BerkeleyDB::Queue', 
507				-Filename => $Dfile,
508				-ArrayBase => 0,
509                      		-Flags    =>  DB_CREATE ,
510		        	-Env 	  => $env,
511		        	-Txn	  => $txn ,
512				-Len      => $rec_len,
513				-Pad      => " " ;
514
515    
516    ok $txn->txn_commit() == 0 ;
517    ok $txn = $env->txn_begin() ;
518    $db1->Txn($txn);
519
520    # create some data
521    my @data =  (
522		"boat",
523		"house",
524		"sea",
525		) ;
526
527    my $ret = 0 ;
528    my $i ;
529    for ($i = 0 ; $i < @data ; ++$i) {
530        $ret += $db1->db_put($i, $data[$i]) ;
531    }
532    ok $ret == 0 ;
533
534    # should be able to see all the records
535
536    ok my $cursor = $db1->db_cursor() ;
537    my ($k, $v) = (0, "") ;
538    my $count = 0 ;
539    # sequence forwards
540    while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
541        ++ $count ;
542    }
543    ok $count == 3 ;
544    undef $cursor ;
545
546    # now abort the transaction
547    ok $txn->txn_abort() == 0 ;
548
549    # there shouldn't be any records in the database
550    $count = 0 ;
551    # sequence forwards
552    ok $cursor = $db1->db_cursor() ;
553    while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
554        ++ $count ;
555    }
556    ok $count == 0 ;
557
558    undef $txn ;
559    undef $cursor ;
560    undef $db1 ;
561    undef $env ;
562    untie @array ;
563}
564
565
566{
567    # db_stat
568
569    my $lex = new LexFile $Dfile ;
570    my $recs = ($BerkeleyDB::db_version >= 3.1 ? "qs_ndata" : "qs_nrecs") ;
571    my @array ;
572    my ($k, $v) ;
573    my $rec_len = 7 ;
574    ok my $db = new BerkeleyDB::Queue -Filename 	=> $Dfile, 
575				     	   -Flags    	=> DB_CREATE,
576					   -Pagesize	=> 4 * 1024,
577				           -Len       => $rec_len,
578				           -Pad       => " " 
579					;
580
581    my $ref = $db->db_stat() ; 
582    ok $ref->{$recs} == 0;
583    ok $ref->{'qs_pagesize'} == 4 * 1024;
584
585    # create some data
586    my @data =  (
587		2,
588		"house",
589		"sea",
590		) ;
591
592    my $ret = 0 ;
593    my $i ;
594    for ($i = $db->ArrayOffset ; @data ; ++$i) {
595        $ret += $db->db_put($i, shift @data) ;
596    }
597    ok $ret == 0 ;
598
599    $ref = $db->db_stat() ; 
600    ok $ref->{$recs} == 3;
601}
602
603{
604   # sub-class test
605
606   package Another ;
607
608   use strict ;
609
610   open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
611   print FILE <<'EOM' ;
612
613   package SubDB ;
614
615   use strict ;
616   use vars qw( @ISA @EXPORT) ;
617
618   require Exporter ;
619   use BerkeleyDB;
620   @ISA=qw(BerkeleyDB BerkeleyDB::Queue);
621   @EXPORT = @BerkeleyDB::EXPORT ;
622
623   sub db_put { 
624	my $self = shift ;
625        my $key = shift ;
626        my $value = shift ;
627        $self->SUPER::db_put($key, $value * 3) ;
628   }
629
630   sub db_get { 
631	my $self = shift ;
632        $self->SUPER::db_get($_[0], $_[1]) ;
633	$_[1] -= 2 ;
634   }
635
636   sub A_new_method
637   {
638	my $self = shift ;
639        my $key = shift ;
640        my $value = $self->FETCH($key) ;
641	return "[[$value]]" ;
642   }
643
644   1 ;
645EOM
646
647    close FILE ;
648
649    BEGIN { push @INC, '.'; }    
650    eval 'use SubDB ; ';
651    main::ok $@ eq "" ;
652    my @h ;
653    my $X ;
654    my $rec_len = 34 ;
655    eval '
656	$X = tie(@h, "SubDB", -Filename => "dbqueue.tmp", 
657			-Flags => DB_CREATE,
658			-Mode => 0640 ,
659	                -Len       => $rec_len,
660	                -Pad       => " " 
661			);		   
662	' ;
663
664    main::ok $@ eq "" ;
665
666    my $ret = eval '$h[1] = 3 ; return $h[1] ' ;
667    main::ok $@ eq "" ;
668    main::ok $ret == 7 ;
669
670    my $value = 0;
671    $ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ;
672    main::ok $@ eq "" ;
673    main::ok $ret == 10 ;
674
675    $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
676    main::ok $@ eq ""  ;
677    main::ok $ret == 1 ;
678
679    $ret = eval '$X->A_new_method(1) ' ;
680    main::ok $@ eq "" ;
681    main::ok $ret eq "[[10]]" ;
682
683    undef $X ;
684    untie @h ;
685    unlink "SubDB.pm", "dbqueue.tmp" ;
686
687}
688
689{
690    # DB_APPEND
691
692    my $lex = new LexFile $Dfile;
693    my @array ;
694    my $value ;
695    my $rec_len = 21 ;
696    ok my $db = tie @array, 'BerkeleyDB::Queue', 
697					-Filename  => $Dfile,
698                                       	-Flags     => DB_CREATE ,
699	                		-Len       => $rec_len,
700	                		-Pad       => " " ;
701
702    # create a few records
703    $array[1] = "def" ;
704    $array[3] = "ghi" ;
705
706    my $k = 0 ;
707    ok $db->db_put($k, "fred", DB_APPEND) == 0 ;
708    ok $k == 4 ;
709    ok $array[4] eq fillout("fred", $rec_len) ;
710
711    undef $db ;
712    untie @array ;
713}
714
715{
716    # 23 Sept 2001 -- push into an empty array
717    my $lex = new LexFile $Dfile ;
718    my @array ;
719    my $db ;
720    my $rec_len = 21 ;
721    ok $db = tie @array, 'BerkeleyDB::Queue', 
722                                      	       	-Flags  => DB_CREATE ,
723				    	        -ArrayBase => 0,
724	                		        -Len       => $rec_len,
725	                		        -Pad       => " " ,
726						-Filename => $Dfile ;
727    $FA ? push @array, "first"
728        : $db->push("first") ;
729
730    ok (($FA ? pop @array : $db->pop()) eq fillout("first", $rec_len)) ;
731
732    undef $db;
733    untie @array ;
734
735}
736
737{
738    # Tied Array interface with transactions
739
740    my $lex = new LexFile $Dfile ;
741    my @array ;
742    my $db ;
743    my $rec_len = 10 ;
744    my $home = "./fred" ;
745    ok my $lexD = new LexDir($home);
746    ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
747				     -Flags => DB_CREATE|DB_INIT_TXN|
748					  	DB_INIT_MPOOL|DB_INIT_LOCK ;
749    ok my $txn = $env->txn_begin() ;
750    ok $db = tie @array, 'BerkeleyDB::Queue', -Filename  => $Dfile,
751				    	    -ArrayBase => 0,
752                            -Flags     => DB_CREATE ,
753                            -Env       => $env ,
754                            -Txn       => $txn ,
755				    	    -Len       => $rec_len;
756
757    ok $txn->txn_commit() == 0 ;
758    ok $txn = $env->txn_begin() ;
759    $db->Txn($txn);
760
761    ok my $cursor = (tied @array)->db_cursor() ;
762    # check the database is empty
763    my $count = 0 ;
764    my ($k, $v) = (0,"") ;
765    while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
766	++ $count ;
767    }
768    ok $cursor->status() == DB_NOTFOUND ;
769    ok $count == 0 ;
770
771    ok @array == 0 ;
772
773    # Add a k/v pair
774    my $value ;
775    $array[1] = "some value";
776    ok ((tied @array)->status() == 0) ;
777    ok $array[1] eq fillout("some value", $rec_len);
778    ok defined $array[1];
779    ok ((tied @array)->status() == 0) ;
780    ok !defined $array[3];
781    ok ((tied @array)->status() == DB_NOTFOUND) ;
782
783    $array[1] = 2 ;
784    $array[10] = 20 ;
785    $array[100] = 200 ;
786
787    my ($keys, $values) = (0,0);
788    $count = 0 ;
789    for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
790	  $status == 0 ;
791    	  $status = $cursor->c_get($k, $v, DB_NEXT)) {
792        $keys += $k ;
793	$values += $v ;
794	++ $count ;
795    }
796    ok $count == 3 ;
797    ok $keys == 111 ;
798    ok $values == 222 ;
799
800    # unshift isn't allowed
801#    eval {
802#    	$FA ? unshift @array, "red", "green", "blue" 
803#        : $db->unshift("red", "green", "blue" ) ;
804#	} ;
805#    ok $@ =~ /^unshift is unsupported with Queue databases/ ;	
806    $array[0] = "red" ;
807    $array[1] = "green" ;
808    $array[2] = "blue" ;
809    $array[4] = 2 ;
810    ok $array[0] eq fillout("red", $rec_len) ;
811    ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;
812    ok $k == 0 ;
813    ok $v eq fillout("red", $rec_len) ;
814    ok $array[1] eq fillout("green", $rec_len) ;
815    ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
816    ok $k == 1 ;
817    ok $v eq fillout("green", $rec_len) ;
818    ok $array[2] eq fillout("blue", $rec_len) ;
819    ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
820    ok $k == 2 ;
821    ok $v eq fillout("blue", $rec_len) ;
822    ok $array[4] == 2 ;
823    ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
824    ok $k == 4 ;
825    ok $v == 2 ;
826
827    # shift
828    ok (($FA ? shift @array : $db->shift()) eq fillout("red", $rec_len)) ;
829    ok (($FA ? shift @array : $db->shift()) eq fillout("green", $rec_len)) ;
830    ok (($FA ? shift @array : $db->shift()) eq fillout("blue", $rec_len)) ;
831    ok (($FA ? shift @array : $db->shift()) == 2) ;
832
833    # push
834    $FA ? push @array, "the", "end" 
835        : $db->push("the", "end") ;
836    ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
837    ok $k == 102 ;
838    ok $v eq fillout("end", $rec_len) ;
839    ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
840    ok $k == 101 ;
841    ok $v eq fillout("the", $rec_len) ;
842    ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
843    ok $k == 100 ;
844    ok $v == 200 ;
845
846    # pop
847    ok (( $FA ? pop @array : $db->pop ) eq fillout("end", $rec_len)) ;
848    ok (( $FA ? pop @array : $db->pop ) eq fillout("the", $rec_len)) ;
849    ok (( $FA ? pop @array : $db->pop ) == 200 ) ;
850
851    # now clear the array 
852    $FA ? @array = () 
853        : $db->clear() ;
854    ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
855    undef $cursor ;
856    ok $txn->txn_commit() == 0 ;
857
858    undef $db ;
859    untie @array ;
860}
861__END__
862
863
864# TODO
865#
866# DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records
867