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