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