This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Tweak gdbm.t to use GDBM_WRITER instead of GDBM_WRCREAT when re-opening a file.
[perl5.git] / ext / ODBM_File / t / odbm.t
CommitLineData
bee1dbe2
LW
1#!./perl
2
a0d0e21e
LW
3# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
4
5BEGIN {
a0d0e21e 6 require Config; import Config;
ae5c2706 7 if ($Config{'extensions'} !~ /\bODBM_File\b/ or $Config{'d_cplusplus'}) {
45c0de28 8 print "1..0 # Skip: ODBM_File was not built\n";
a0d0e21e
LW
9 exit 0;
10 }
11}
12
698828ad
JH
13use strict;
14use warnings;
15
876dc03f 16use Test::More tests => 79;
698828ad 17
a0d0e21e
LW
18require ODBM_File;
19#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
20use Fcntl;
21
a0d0e21e
LW
22unlink <Op.dbmx*>;
23
bee1dbe2 24umask(0);
698828ad 25my %h;
876dc03f 26isa_ok(tie(%h, 'ODBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640), 'ODBM_File');
a0d0e21e 27
698828ad 28my $Dfile = "Op.dbmx.pag";
a0d0e21e
LW
29if (! -e $Dfile) {
30 ($Dfile) = <Op.dbmx*>;
31}
876dc03f
NC
32SKIP: {
33 skip "different file permission semantics on $^O", 1
34 if $^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare';
698828ad 35 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
544a3566 36 $blksize,$blocks) = stat($Dfile);
876dc03f 37 is($mode & 0777, 0640);
544a3566 38}
698828ad
JH
39my $i = 0;
40while (my ($key,$value) = each(%h)) {
bee1dbe2
LW
41 $i++;
42}
876dc03f 43is($i, 0);
bee1dbe2
LW
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';
62delete $h{'goner2'};
63
a0d0e21e 64untie(%h);
876dc03f 65isa_ok(tie(%h, 'ODBM_File', 'Op.dbmx', O_RDWR, 0640), 'ODBM_File');
bee1dbe2
LW
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
87delete $h{'goner1'};
88delete $h{'goner3'};
89
698828ad
JH
90my @keys = keys(%h);
91my @values = values(%h);
bee1dbe2 92
876dc03f
NC
93is($#keys, 29);
94is($#values, 29);
bee1dbe2 95
698828ad 96while (my ($key,$value) = each(%h)) {
2f52a358 97 if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
bee1dbe2
LW
98 $key =~ y/a-z/A-Z/;
99 $i++ if $key eq $value;
100 }
101}
102
876dc03f 103is($i, 30);
bee1dbe2 104
c6aa4a32 105@keys = ('blurfl', keys(%h), 'dyick');
876dc03f 106is($#keys, 31);
bee1dbe2
LW
107
108$h{'foo'} = '';
109$h{''} = 'bar';
110
698828ad 111my $ok = 1;
bee1dbe2
LW
112for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
113for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
876dc03f 114is($ok, 1, 'check cache overflow and numeric keys and contents');
bee1dbe2 115
698828ad 116my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
a0d0e21e 117 $blksize,$blocks) = stat($Dfile);
876dc03f 118cmp_ok($size, '>', 0);
bee1dbe2
LW
119
120@h{0..200} = 200..400;
698828ad 121my @foo = @h{0..200};
876dc03f 122is(join(':',200..400), join(':',@foo));
bee1dbe2 123
876dc03f
NC
124is($h{'foo'}, '');
125is($h{''}, 'bar');
bee1dbe2 126
bbad3607 127untie %h;
a0d0e21e 128unlink 'Op.dbmx.dir', $Dfile;
4e2a63a7 129
4e2a63a7
PM
130{
131 # sub-class test
132
133 package Another ;
134
4e2a63a7
PM
135 open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
136 print FILE <<'EOM' ;
137
138 package SubDB ;
139
140 use strict ;
698828ad 141 use warnings ;
4e2a63a7
PM
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 ;
171EOM
172
173 close FILE ;
174
175 BEGIN { push @INC, '.'; }
176
177 eval 'use SubDB ; use Fcntl ;';
876dc03f 178 main::is($@, "");
4e2a63a7
PM
179 my %h ;
180 my $X ;
181 eval '
182 $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 );
183 ' ;
184
876dc03f 185 main::is($@, "");
4e2a63a7
PM
186
187 my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
876dc03f
NC
188 main::is($@, "");
189 main::is($ret, 5);
4e2a63a7
PM
190
191 $ret = eval '$X->A_new_method("fred") ' ;
876dc03f
NC
192 main::is($@, "");
193 main::is($ret, "[[5]]");
4e2a63a7 194
fac76ed7
MB
195 undef $X;
196 untie(%h);
84902520 197 unlink "SubDB.pm", <dbhash.tmp*> ;
4e2a63a7
PM
198
199}
9fe6733a
PM
200
201{
202 # DBM Filter tests
9fe6733a
PM
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) = @_ ;
1b882d32
GS
209 print "# ", join('|', $fetch_key, $fk, $store_key, $sk,
210 $fetch_value, $fv, $store_value, $sv, $_), "\n";
9fe6733a
PM
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*>;
876dc03f
NC
218 $db = tie %h, 'ODBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640;
219 isa_ok($db, 'ODBM_File');
9fe6733a
PM
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
876dc03f 230 ok(checkOutput("", "fred", "", "joe"));
9fe6733a
PM
231
232 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f 233 is($h{"fred"}, "joe");
9fe6733a 234 # fk sk fv sv
876dc03f 235 ok(checkOutput("", "fred", "joe", ""));
9fe6733a
PM
236
237 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f 238 is($db->FIRSTKEY(), "fred");
9fe6733a 239 # fk sk fv sv
876dc03f 240 ok(checkOutput("fred", "", "", ""));
9fe6733a
PM
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
876dc03f 255 ok(checkOutput("", "fred", "", "Jxe"));
9fe6733a
PM
256
257 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f 258 is($h{"Fred"}, "[Jxe]");
9fe6733a 259 # fk sk fv sv
876dc03f 260 ok(checkOutput("", "fred", "[Jxe]", ""));
9fe6733a
PM
261
262 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f 263 is($db->FIRSTKEY(), "FRED");
9fe6733a 264 # fk sk fv sv
876dc03f 265 ok(checkOutput("FRED", "", "", ""));
9fe6733a
PM
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" ;
876dc03f 275 ok(checkOutput("", "fred", "", "joe"));
9fe6733a
PM
276
277 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f
NC
278 is($h{"fred"}, "joe");
279 ok(checkOutput("", "fred", "joe", ""));
9fe6733a
PM
280
281 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f
NC
282 is($db->FIRSTKEY(), "fred");
283 ok(checkOutput("fred", "", "", ""));
9fe6733a
PM
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" ;
876dc03f 293 ok(checkOutput("", "", "", ""));
9fe6733a
PM
294
295 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f
NC
296 is($h{"fred"}, "joe");
297 ok(checkOutput("", "", "", ""));
9fe6733a
PM
298
299 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f
NC
300 is($db->FIRSTKEY(), "fred");
301 ok(checkOutput("", "", "", ""));
9fe6733a
PM
302
303 undef $db ;
304 untie %h;
305 unlink <Op.dbmx*>;
306}
307
308{
309 # DBM Filter with a closure
310
9fe6733a
PM
311 my (%h, $db) ;
312
313 unlink <Op.dbmx*>;
876dc03f
NC
314 $db = tie %h, 'ODBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640;
315 isa_ok($db, 'ODBM_File');
9fe6733a
PM
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" ;
876dc03f
NC
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");
9fe6733a
PM
351
352 $h{"jim"} = "john" ;
876dc03f
NC
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");
9fe6733a
PM
365
366 undef $db ;
367 untie %h;
368 unlink <Op.dbmx*>;
369}
370
371{
372 # DBM Filter recursion detection
9fe6733a
PM
373 my (%h, $db) ;
374 unlink <Op.dbmx*>;
375
876dc03f
NC
376 $db = tie %h, 'ODBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640;
377 isa_ok($db, 'ODBM_File');
9fe6733a
PM
378
379 $db->filter_store_key (sub { $_ = $h{$_} }) ;
380
381 eval '$h{1} = 1234' ;
876dc03f 382 like($@, qr/^recursion detected in filter_store_key at/);
9fe6733a
PM
383
384 undef $db ;
385 untie %h;
386 unlink <Op.dbmx*>;
387}
9394203c 388
cbc5248d
PM
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
cbc5248d
PM
394
395 unlink <Op.dbmx*>;
396 my %h ;
397 my $a = "";
398 local $SIG{__WARN__} = sub {$a = $_[0]} ;
399
876dc03f 400 isa_ok(tie(%h, 'ODBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640), 'ODBM_File');
cbc5248d 401 $h{ABC} = undef;
876dc03f 402 is($a, "");
cbc5248d
PM
403 untie %h;
404 unlink <Op.dbmx*>;
405}
406
0bf2e707
PM
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
0bf2e707
PM
414 unlink <Op.dbmx*>;
415 my $bad_key = 0 ;
416 my %h = () ;
876dc03f
NC
417 my $db = tie %h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640;
418 isa_ok($db, 'ODBM_File');
0bf2e707
PM
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
876dc03f
NC
425 is($h{'Alpha_ABC'}, 2);
426 is($h{'Alpha_DEF'}, 5);
0bf2e707
PM
427
428 my ($k, $v) = ("","");
429 while (($k, $v) = each %h) {}
876dc03f 430 is($bad_key, 0);
0bf2e707
PM
431
432 $bad_key = 0 ;
433 foreach $k (keys %h) {}
876dc03f 434 is($bad_key, 0);
0bf2e707
PM
435
436 $bad_key = 0 ;
437 foreach $v (values %h) {}
876dc03f 438 is($bad_key, 0);
0bf2e707
PM
439
440 undef $db ;
441 untie %h ;
442 unlink <Op.dbmx*>;
443}
444
6a31061a
PM
445
446{
447 # Check that DBM Filter can cope with read-only $_
448
6a31061a
PM
449 my %h ;
450 unlink <Op.dbmx*>;
451
876dc03f
NC
452 my $db = tie %h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640;
453 isa_ok($db, 'ODBM_File');
6a31061a
PM
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" ;
876dc03f 463 is($h{"fred"}, "joe");
6a31061a
PM
464
465 eval { grep { $h{$_} } (1, 2, 3) };
876dc03f 466 is($@, '');
6a31061a
PM
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
876dc03f 477 is($h{"fred"}, "joe");
6a31061a 478
876dc03f 479 is($db->FIRSTKEY(), "fred");
6a31061a
PM
480
481 eval { grep { $h{$_} } (1, 2, 3) };
876dc03f 482 is($@, '');
6a31061a
PM
483
484 undef $db ;
485 untie %h;
486 unlink <Op.dbmx*>;
487}
876dc03f 488
9394203c
JH
489if ($^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#
497EOM
498}