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