1#!./perl
2
3# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
4
5BEGIN {
6    chdir 't' if -d 't';
7    @INC = '../lib';
8    require Config; import Config;
9    if ($Config{'extensions'} !~ /\bNDBM_File\b/) {
10	print "1..0 # Skip: NDBM_File was not built\n";
11	exit 0;
12    }
13}
14
15use strict;
16use warnings;
17
18sub ok
19{
20    my $no = shift ;
21    my $result = shift ;
22
23    print "not " unless $result ;
24    print "ok $no\n" ;
25}
26
27require NDBM_File;
28#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
29use Fcntl;
30
31print "1..77\n";
32
33unlink <Op.dbmx*>;
34
35umask(0);
36my %h;
37ok(1, tie(%h,'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640));
38
39my $Dfile = "Op.dbmx.pag";
40if (! -e $Dfile) {
41	($Dfile) = <Op.dbmx*>;
42}
43if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'MacOS') {
44    print "ok 2 # Skipped: different file permission semantics\n";
45}
46else {
47    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
48     $blksize,$blocks) = stat($Dfile);
49    print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
50}
51my $i = 0;
52while (my ($key,$value) = each(%h)) {
53    $i++;
54}
55print (!$i ? "ok 3\n" : "not ok 3\n");
56
57$h{'goner1'} = 'snork';
58
59$h{'abc'} = 'ABC';
60$h{'def'} = 'DEF';
61$h{'jkl','mno'} = "JKL\034MNO";
62$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
63$h{'a'} = 'A';
64$h{'b'} = 'B';
65$h{'c'} = 'C';
66$h{'d'} = 'D';
67$h{'e'} = 'E';
68$h{'f'} = 'F';
69$h{'g'} = 'G';
70$h{'h'} = 'H';
71$h{'i'} = 'I';
72
73$h{'goner2'} = 'snork';
74delete $h{'goner2'};
75
76untie(%h);
77print (tie(%h,'NDBM_File','Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
78
79$h{'j'} = 'J';
80$h{'k'} = 'K';
81$h{'l'} = 'L';
82$h{'m'} = 'M';
83$h{'n'} = 'N';
84$h{'o'} = 'O';
85$h{'p'} = 'P';
86$h{'q'} = 'Q';
87$h{'r'} = 'R';
88$h{'s'} = 'S';
89$h{'t'} = 'T';
90$h{'u'} = 'U';
91$h{'v'} = 'V';
92$h{'w'} = 'W';
93$h{'x'} = 'X';
94$h{'y'} = 'Y';
95$h{'z'} = 'Z';
96
97$h{'goner3'} = 'snork';
98
99delete $h{'goner1'};
100delete $h{'goner3'};
101
102my @keys = keys(%h);
103my @values = values(%h);
104
105if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
106
107while (my ($key,$value) = each(%h)) {
108    if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
109	$key =~ y/a-z/A-Z/;
110	$i++ if $key eq $value;
111    }
112}
113
114if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
115
116@keys = ('blurfl', keys(%h), 'dyick');
117if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
118
119$h{'foo'} = '';
120$h{''} = 'bar';
121
122# check cache overflow and numeric keys and contents
123my $ok = 1;
124for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
125for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
126print ($ok ? "ok 8\n" : "not ok 8\n");
127
128my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
129   $blksize,$blocks) = stat($Dfile);
130print ($size > 0 ? "ok 9\n" : "not ok 9\n");
131
132@h{0..200} = 200..400;
133my @foo = @h{0..200};
134print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
135
136print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
137print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
138
139untie %h;
140unlink <Op.dbmx*>, $Dfile;
141
142{
143   # sub-class test
144
145   package Another ;
146
147   use strict ;
148   use warnings ;
149
150   open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
151   print FILE <<'EOM' ;
152
153   package SubDB ;
154
155   use strict ;
156   use warnings ;
157   use vars qw(@ISA @EXPORT) ;
158
159   require Exporter ;
160   use NDBM_File;
161   @ISA=qw(NDBM_File);
162   @EXPORT = @NDBM_File::EXPORT if defined @NDBM_File::EXPORT ;
163
164   sub STORE { 
165	my $self = shift ;
166        my $key = shift ;
167        my $value = shift ;
168        $self->SUPER::STORE($key, $value * 2) ;
169   }
170
171   sub FETCH { 
172	my $self = shift ;
173        my $key = shift ;
174        $self->SUPER::FETCH($key) - 1 ;
175   }
176
177   sub A_new_method
178   {
179	my $self = shift ;
180        my $key = shift ;
181        my $value = $self->FETCH($key) ;
182	return "[[$value]]" ;
183   }
184
185   1 ;
186EOM
187
188    close FILE ;
189
190    BEGIN { push @INC, '.'; }
191
192    eval 'use SubDB ; use Fcntl ; ';
193    main::ok(13, $@ eq "") ;
194    my %h ;
195    my $X ;
196    eval '
197	$X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 );
198	' ;
199
200    main::ok(14, $@ eq "") ;
201
202    my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
203    main::ok(15, $@ eq "") ;
204    main::ok(16, $ret == 5) ;
205
206    $ret = eval '$X->A_new_method("fred") ' ;
207    main::ok(17, $@ eq "") ;
208    main::ok(18, $ret eq "[[5]]") ;
209
210    undef $X;
211    untie(%h);
212    unlink "SubDB.pm", <dbhash.tmp*> ;
213
214}
215
216{
217   # DBM Filter tests
218   use strict ;
219   use warnings ;
220   my (%h, $db) ;
221   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
222
223   sub checkOutput
224   {
225       my($fk, $sk, $fv, $sv) = @_ ;
226       return
227           $fetch_key eq $fk && $store_key eq $sk && 
228	   $fetch_value eq $fv && $store_value eq $sv &&
229	   $_ eq 'original' ;
230   }
231   
232   unlink <Op.dbmx*>;
233   ok(19, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
234
235   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
236   $db->filter_store_key   (sub { $store_key = $_ }) ;
237   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
238   $db->filter_store_value (sub { $store_value = $_ }) ;
239
240   $_ = "original" ;
241
242   $h{"fred"} = "joe" ;
243   #                   fk   sk     fv   sv
244   ok(20, checkOutput( "", "fred", "", "joe")) ;
245
246   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
247   ok(21, $h{"fred"} eq "joe");
248   #                   fk    sk     fv    sv
249   ok(22, checkOutput( "", "fred", "joe", "")) ;
250
251   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
252   ok(23, $db->FIRSTKEY() eq "fred") ;
253   #                    fk     sk  fv  sv
254   ok(24, checkOutput( "fred", "", "", "")) ;
255
256   # replace the filters, but remember the previous set
257   my ($old_fk) = $db->filter_fetch_key   
258   			(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
259   my ($old_sk) = $db->filter_store_key   
260   			(sub { $_ = lc $_ ; $store_key = $_ }) ;
261   my ($old_fv) = $db->filter_fetch_value 
262   			(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
263   my ($old_sv) = $db->filter_store_value 
264   			(sub { s/o/x/g; $store_value = $_ }) ;
265   
266   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
267   $h{"Fred"} = "Joe" ;
268   #                   fk   sk     fv    sv
269   ok(25, checkOutput( "", "fred", "", "Jxe")) ;
270
271   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
272   ok(26, $h{"Fred"} eq "[Jxe]");
273   #                   fk   sk     fv    sv
274   ok(27, checkOutput( "", "fred", "[Jxe]", "")) ;
275
276   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
277   ok(28, $db->FIRSTKEY() eq "FRED") ;
278   #                   fk   sk     fv    sv
279   ok(29, checkOutput( "FRED", "", "", "")) ;
280
281   # put the original filters back
282   $db->filter_fetch_key   ($old_fk);
283   $db->filter_store_key   ($old_sk);
284   $db->filter_fetch_value ($old_fv);
285   $db->filter_store_value ($old_sv);
286
287   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
288   $h{"fred"} = "joe" ;
289   ok(30, checkOutput( "", "fred", "", "joe")) ;
290
291   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
292   ok(31, $h{"fred"} eq "joe");
293   ok(32, checkOutput( "", "fred", "joe", "")) ;
294
295   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
296   ok(33, $db->FIRSTKEY() eq "fred") ;
297   ok(34, checkOutput( "fred", "", "", "")) ;
298
299   # delete the filters
300   $db->filter_fetch_key   (undef);
301   $db->filter_store_key   (undef);
302   $db->filter_fetch_value (undef);
303   $db->filter_store_value (undef);
304
305   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
306   $h{"fred"} = "joe" ;
307   ok(35, checkOutput( "", "", "", "")) ;
308
309   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
310   ok(36, $h{"fred"} eq "joe");
311   ok(37, checkOutput( "", "", "", "")) ;
312
313   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
314   ok(38, $db->FIRSTKEY() eq "fred") ;
315   ok(39, checkOutput( "", "", "", "")) ;
316
317   undef $db ;
318   untie %h;
319   unlink <Op.dbmx*>;
320}
321
322{    
323    # DBM Filter with a closure
324
325    use strict ;
326    use warnings ;
327    my (%h, $db) ;
328
329    unlink <Op.dbmx*>;
330    ok(40, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
331
332    my %result = () ;
333
334    sub Closure
335    {
336        my ($name) = @_ ;
337	my $count = 0 ;
338	my @kept = () ;
339
340	return sub { ++$count ; 
341		     push @kept, $_ ; 
342		     $result{$name} = "$name - $count: [@kept]" ;
343		   }
344    }
345
346    $db->filter_store_key(Closure("store key")) ;
347    $db->filter_store_value(Closure("store value")) ;
348    $db->filter_fetch_key(Closure("fetch key")) ;
349    $db->filter_fetch_value(Closure("fetch value")) ;
350
351    $_ = "original" ;
352
353    $h{"fred"} = "joe" ;
354    ok(41, $result{"store key"} eq "store key - 1: [fred]");
355    ok(42, $result{"store value"} eq "store value - 1: [joe]");
356    ok(43, !defined $result{"fetch key"} );
357    ok(44, !defined $result{"fetch value"} );
358    ok(45, $_ eq "original") ;
359
360    ok(46, $db->FIRSTKEY() eq "fred") ;
361    ok(47, $result{"store key"} eq "store key - 1: [fred]");
362    ok(48, $result{"store value"} eq "store value - 1: [joe]");
363    ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]");
364    ok(50, ! defined $result{"fetch value"} );
365    ok(51, $_ eq "original") ;
366
367    $h{"jim"}  = "john" ;
368    ok(52, $result{"store key"} eq "store key - 2: [fred jim]");
369    ok(53, $result{"store value"} eq "store value - 2: [joe john]");
370    ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");
371    ok(55, ! defined $result{"fetch value"} );
372    ok(56, $_ eq "original") ;
373
374    ok(57, $h{"fred"} eq "joe");
375    ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]");
376    ok(59, $result{"store value"} eq "store value - 2: [joe john]");
377    ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]");
378    ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]");
379    ok(62, $_ eq "original") ;
380
381    undef $db ;
382    untie %h;
383    unlink <Op.dbmx*>;
384}		
385
386{
387   # DBM Filter recursion detection
388   use strict ;
389   use warnings ;
390   my (%h, $db) ;
391   unlink <Op.dbmx*>;
392
393   ok(63, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
394
395   $db->filter_store_key (sub { $_ = $h{$_} }) ;
396
397   eval '$h{1} = 1234' ;
398   ok(64, $@ =~ /^recursion detected in filter_store_key at/ );
399   
400   undef $db ;
401   untie %h;
402   unlink <Op.dbmx*>;
403}
404
405{
406    # Bug ID 20001013.009
407    #
408    # test that $hash{KEY} = undef doesn't produce the warning
409    #     Use of uninitialized value in null operation 
410    use warnings ;
411    use strict ;
412    use NDBM_File ;
413
414    unlink <Op.dbmx*>;
415    my %h ;
416    my $a = "";
417    local $SIG{__WARN__} = sub {$a = $_[0]} ;
418    
419    ok(65, tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
420}
421
422{
423    # When iterating over a tied hash using "each", the key passed to FETCH
424    # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
425    # key in FETCH via a filter_fetch_key method we need to check that the
426    # modified key doesn't get passed to NEXTKEY.
427    # Also Test "keys" & "values" while we are at it.
428
429    use warnings ;
430    use strict ;
431    use NDBM_File ;
432
433    unlink <Op.dbmx*>;
434    my $bad_key = 0 ;
435    my %h = () ;
436    ok(66, my $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
437    $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
438    $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
439
440    $h{'Alpha_ABC'} = 2 ;
441    $h{'Alpha_DEF'} = 5 ;
442
443    ok(67, $h{'Alpha_ABC'} == 2);
444    ok(68, $h{'Alpha_DEF'} == 5);
445
446    my ($k, $v) = ("","");
447    while (($k, $v) = each %h) {}
448    ok(69, $bad_key == 0);
449
450    $bad_key = 0 ;
451    foreach $k (keys %h) {}
452    ok(70, $bad_key == 0);
453
454    $bad_key = 0 ;
455    foreach $v (values %h) {}
456    ok(71, $bad_key == 0);
457
458    undef $db ;
459    untie %h ;
460    unlink <Op.dbmx*>;
461}
462
463
464{
465   # Check that DBM Filter can cope with read-only $_
466
467   use warnings ;
468   use strict ;
469   my %h ;
470   unlink <Op.dbmx*>;
471
472   ok(72, my $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
473
474   $db->filter_fetch_key   (sub { }) ;
475   $db->filter_store_key   (sub { }) ;
476   $db->filter_fetch_value (sub { }) ;
477   $db->filter_store_value (sub { }) ;
478
479   $_ = "original" ;
480
481   $h{"fred"} = "joe" ;
482   ok(73, $h{"fred"} eq "joe");
483
484   eval { grep { $h{$_} } (1, 2, 3) };
485   ok (74, ! $@);
486
487
488   # delete the filters
489   $db->filter_fetch_key   (undef);
490   $db->filter_store_key   (undef);
491   $db->filter_fetch_value (undef);
492   $db->filter_store_value (undef);
493
494   $h{"fred"} = "joe" ;
495
496   ok(75, $h{"fred"} eq "joe");
497
498   ok(76, $db->FIRSTKEY() eq "fred") ;
499   
500   eval { grep { $h{$_} } (1, 2, 3) };
501   ok (77, ! $@);
502
503   undef $db ;
504   untie %h;
505   unlink <Op.dbmx*>;
506}
507exit ;
508