1#!./perl -w
2
3# ID: %I%, %G%   
4
5use strict ;
6
7use lib 't' ;
8use BerkeleyDB; 
9use util ;
10
11print "1..52\n";
12
13my $Dfile = "dbhash.tmp";
14unlink $Dfile;
15
16umask(0) ;
17
18
19{
20   # DBM Filter tests
21   use strict ;
22   my (%h, $db) ;
23   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
24   unlink $Dfile;
25
26   sub checkOutput
27   {
28       my($fk, $sk, $fv, $sv) = @_ ;
29       return
30           $fetch_key eq $fk && $store_key eq $sk && 
31	   $fetch_value eq $fv && $store_value eq $sv &&
32	   $_ eq 'original' ;
33   }
34   
35    ok 1, $db = tie %h, 'BerkeleyDB::Hash', 
36    		-Filename   => $Dfile, 
37	        -Flags      => DB_CREATE; 
38
39   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
40   $db->filter_store_key   (sub { $store_key = $_ }) ;
41   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
42   $db->filter_store_value (sub { $store_value = $_ }) ;
43
44   $_ = "original" ;
45
46   $h{"fred"} = "joe" ;
47   #                   fk   sk     fv   sv
48   ok 2, checkOutput( "", "fred", "", "joe") ;
49
50   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
51   ok 3, $h{"fred"} eq "joe";
52   #                   fk    sk     fv    sv
53   ok 4, checkOutput( "", "fred", "joe", "") ;
54
55   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
56   ok 5, $db->FIRSTKEY() eq "fred" ;
57   #                    fk     sk  fv  sv
58   ok 6, checkOutput( "fred", "", "", "") ;
59
60   # replace the filters, but remember the previous set
61   my ($old_fk) = $db->filter_fetch_key   
62   			(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
63   my ($old_sk) = $db->filter_store_key   
64   			(sub { $_ = lc $_ ; $store_key = $_ }) ;
65   my ($old_fv) = $db->filter_fetch_value 
66   			(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
67   my ($old_sv) = $db->filter_store_value 
68   			(sub { s/o/x/g; $store_value = $_ }) ;
69   
70   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
71   $h{"Fred"} = "Joe" ;
72   #                   fk   sk     fv    sv
73   ok 7, checkOutput( "", "fred", "", "Jxe") ;
74
75   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
76   ok 8, $h{"Fred"} eq "[Jxe]";
77   print "$h{'Fred'}\n";
78   #                   fk   sk     fv    sv
79   ok 9, checkOutput( "", "fred", "[Jxe]", "") ;
80
81   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
82   ok 10, $db->FIRSTKEY() eq "FRED" ;
83   #                   fk   sk     fv    sv
84   ok 11, checkOutput( "FRED", "", "", "") ;
85
86   # put the original filters back
87   $db->filter_fetch_key   ($old_fk);
88   $db->filter_store_key   ($old_sk);
89   $db->filter_fetch_value ($old_fv);
90   $db->filter_store_value ($old_sv);
91
92   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
93   $h{"fred"} = "joe" ;
94   ok 12, checkOutput( "", "fred", "", "joe") ;
95
96   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
97   ok 13, $h{"fred"} eq "joe";
98   ok 14, checkOutput( "", "fred", "joe", "") ;
99
100   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
101   ok 15, $db->FIRSTKEY() eq "fred" ;
102   ok 16, checkOutput( "fred", "", "", "") ;
103
104   # delete the filters
105   $db->filter_fetch_key   (undef);
106   $db->filter_store_key   (undef);
107   $db->filter_fetch_value (undef);
108   $db->filter_store_value (undef);
109
110   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
111   $h{"fred"} = "joe" ;
112   ok 17, checkOutput( "", "", "", "") ;
113
114   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
115   ok 18, $h{"fred"} eq "joe";
116   ok 19, checkOutput( "", "", "", "") ;
117
118   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
119   ok 20, $db->FIRSTKEY() eq "fred" ;
120   ok 21, checkOutput( "", "", "", "") ;
121
122   undef $db ;
123   untie %h;
124   unlink $Dfile;
125}
126
127{    
128    # DBM Filter with a closure
129
130    use strict ;
131    my (%h, $db) ;
132
133    unlink $Dfile;
134    ok 22, $db = tie %h, 'BerkeleyDB::Hash', 
135    		-Filename   => $Dfile, 
136	        -Flags      => DB_CREATE; 
137
138    my %result = () ;
139
140    sub Closure
141    {
142        my ($name) = @_ ;
143	my $count = 0 ;
144	my @kept = () ;
145
146	return sub { ++$count ; 
147		     push @kept, $_ ; 
148		     $result{$name} = "$name - $count: [@kept]" ;
149		   }
150    }
151
152    $db->filter_store_key(Closure("store key"))  ;
153    $db->filter_store_value(Closure("store value")) ;
154    $db->filter_fetch_key(Closure("fetch key")) ;
155    $db->filter_fetch_value(Closure("fetch value")) ;
156
157    $_ = "original" ;
158
159    $h{"fred"} = "joe" ;
160    ok 23, $result{"store key"} eq "store key - 1: [fred]" ;
161    ok 24, $result{"store value"} eq "store value - 1: [joe]" ;
162    ok 25, ! defined $result{"fetch key"}  ;
163    ok 26, ! defined $result{"fetch value"}  ;
164    ok 27, $_ eq "original"  ;
165
166    ok 28, $db->FIRSTKEY() eq "fred"  ;
167    ok 29, $result{"store key"} eq "store key - 1: [fred]" ;
168    ok 30, $result{"store value"} eq "store value - 1: [joe]" ;
169    ok 31, $result{"fetch key"} eq "fetch key - 1: [fred]" ;
170    ok 32, ! defined $result{"fetch value"}  ;
171    ok 33, $_ eq "original"  ;
172
173    $h{"jim"}  = "john" ;
174    ok 34, $result{"store key"} eq "store key - 2: [fred jim]" ;
175    ok 35, $result{"store value"} eq "store value - 2: [joe john]" ;
176    ok 36, $result{"fetch key"} eq "fetch key - 1: [fred]" ;
177    ok 37, ! defined $result{"fetch value"}  ;
178    ok 38, $_ eq "original"  ;
179
180    ok 39, $h{"fred"} eq "joe" ;
181    ok 40, $result{"store key"} eq "store key - 3: [fred jim fred]" ;
182    ok 41, $result{"store value"} eq "store value - 2: [joe john]" ;
183    ok 42, $result{"fetch key"} eq "fetch key - 1: [fred]" ;
184    ok 43, $result{"fetch value"} eq "fetch value - 1: [joe]" ;
185    ok 44, $_ eq "original" ;
186
187    undef $db ;
188    untie %h;
189    unlink $Dfile;
190}		
191
192{
193   # DBM Filter recursion detection
194   use strict ;
195   my (%h, $db) ;
196   unlink $Dfile;
197
198    ok 45, $db = tie %h, 'BerkeleyDB::Hash', 
199    		-Filename   => $Dfile, 
200	        -Flags      => DB_CREATE; 
201
202   $db->filter_store_key (sub { $_ = $h{$_} }) ;
203
204   eval '$h{1} = 1234' ;
205   ok 46, $@ =~ /^recursion detected in filter_store_key at/ ;
206   
207   undef $db ;
208   untie %h;
209   unlink $Dfile;
210}
211
212{
213   # Check that DBM Filter can cope with read-only $_
214
215   #use warnings ;
216   use strict ;
217   my (%h, $db) ;
218   unlink $Dfile;
219
220   ok 47, $db = tie %h, 'BerkeleyDB::Hash', 
221    		-Filename   => $Dfile, 
222	        -Flags      => DB_CREATE; 
223
224   $db->filter_fetch_key   (sub { }) ;
225   $db->filter_store_key   (sub { }) ;
226   $db->filter_fetch_value (sub { }) ;
227   $db->filter_store_value (sub { }) ;
228
229   $_ = "original" ;
230
231   $h{"fred"} = "joe" ;
232   ok(48, $h{"fred"} eq "joe");
233
234   eval { grep { $h{$_} } (1, 2, 3) };
235   ok (49, ! $@);
236
237
238   # delete the filters
239   $db->filter_fetch_key   (undef);
240   $db->filter_store_key   (undef);
241   $db->filter_fetch_value (undef);
242   $db->filter_store_value (undef);
243
244   $h{"fred"} = "joe" ;
245
246   ok(50, $h{"fred"} eq "joe");
247
248   ok(51, $db->FIRSTKEY() eq "fred") ;
249   
250   eval { grep { $h{$_} } (1, 2, 3) };
251   ok (52, ! $@);
252
253   undef $db ;
254   untie %h;
255   unlink $Dfile;
256}
257
258if(0)
259{
260    # Filter without tie
261    use strict ;
262    my (%h, $db) ;
263
264    unlink $Dfile;
265    ok 53, $db = tie %h, 'BerkeleyDB::Hash', 
266    		-Filename   => $Dfile, 
267	        -Flags      => DB_CREATE; 
268
269    my %result = () ;
270
271    sub INC { return ++ $_[0] }
272    sub DEC { return -- $_[0] }
273    #$db->filter_fetch_key   (sub { warn "FFK $_\n"; $_ = INC($_); warn "XX\n" }) ;
274    #$db->filter_store_key   (sub { warn "FSK $_\n"; $_ = DEC($_); warn "XX\n" }) ;
275    #$db->filter_fetch_value (sub { warn "FFV $_\n"; $_ = INC($_); warn "XX\n"}) ;
276    #$db->filter_store_value (sub { warn "FSV $_\n"; $_ = DEC($_); warn "XX\n" }) ;
277
278    $db->filter_fetch_key   (sub { warn "FFK $_\n"; $_ = pack("i", $_); warn "XX\n" }) ;
279    $db->filter_store_key   (sub { warn "FSK $_\n"; $_ = unpack("i", $_); warn "XX\n" }) ;
280    $db->filter_fetch_value (sub { warn "FFV $_\n"; $_ = pack("i", $_); warn "XX\n"}) ;
281    #$db->filter_store_value (sub { warn "FSV $_\n"; $_ = unpack("i", $_); warn "XX\n" }) ;
282
283    #$db->filter_fetch_key   (sub { ++ $_ }) ;
284    #$db->filter_store_key   (sub { -- $_ }) ;
285    #$db->filter_fetch_value (sub { ++ $_ }) ;
286    #$db->filter_store_value (sub { -- $_ }) ;
287
288    my ($k, $v) = (0,0);
289    ok 54, ! $db->db_put(3,5);
290    exit;
291    ok 55, ! $db->db_get(3, $v);
292    ok 56, $v == 5 ;
293
294    $h{4} = 7 ;
295    ok 57, $h{4} == 7;
296
297    $k = 10;
298    $v = 30;
299    $h{$k} = $v ;
300    ok 58, $k == 10;
301    ok 59, $v == 30;
302    ok 60, $h{$k} == 30;
303
304    $k = 3;
305    ok 61, ! $db->db_get($k, $v, DB_GET_BOTH);
306    ok 62, $k == 3 ;
307    ok 63, $v == 5 ;
308
309    my $cursor = $db->db_cursor();
310
311    my %tmp = ();
312    while ($cursor->c_get($k, $v, DB_NEXT) == 0)
313    {
314	$tmp{$k} = $v;
315    }
316
317    ok 64, keys %tmp == 3 ;
318    ok 65, $tmp{3} == 5;
319
320    undef $cursor ;
321    undef $db ;
322    untie %h;
323    unlink $Dfile;
324}
325