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