This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Convert ext/NDBM_File/t/ndbm.t to Test::More.
[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
16sub ok
17{
18 my $no = shift ;
19 my $result = shift ;
20
21 print "not " unless $result ;
22 print "ok $no\n" ;
23}
24
a0d0e21e
LW
25require ODBM_File;
26#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
27use Fcntl;
28
6a31061a 29print "1..78\n";
bee1dbe2 30
a0d0e21e
LW
31unlink <Op.dbmx*>;
32
bee1dbe2 33umask(0);
698828ad
JH
34my %h;
35ok(1, tie(%h,'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640));
a0d0e21e 36
698828ad 37my $Dfile = "Op.dbmx.pag";
a0d0e21e
LW
38if (! -e $Dfile) {
39 ($Dfile) = <Op.dbmx*>;
40}
2986a63f 41if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare') {
fac76ed7 42 print "ok 2 # Skipped: different file permission semantics\n";
544a3566
CS
43}
44else {
698828ad 45 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
544a3566
CS
46 $blksize,$blocks) = stat($Dfile);
47 print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
48}
698828ad
JH
49my $i = 0;
50while (my ($key,$value) = each(%h)) {
bee1dbe2
LW
51 $i++;
52}
53print (!$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';
72delete $h{'goner2'};
73
a0d0e21e 74untie(%h);
698828ad 75print (tie(%h,'ODBM_File','Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
bee1dbe2
LW
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
97delete $h{'goner1'};
98delete $h{'goner3'};
99
698828ad
JH
100my @keys = keys(%h);
101my @values = values(%h);
bee1dbe2
LW
102
103if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
104
698828ad 105while (my ($key,$value) = each(%h)) {
2f52a358 106 if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
bee1dbe2
LW
107 $key =~ y/a-z/A-Z/;
108 $i++ if $key eq $value;
109 }
110}
111
112if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
113
c6aa4a32 114@keys = ('blurfl', keys(%h), 'dyick');
bee1dbe2
LW
115if ($#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
698828ad 121my $ok = 1;
bee1dbe2
LW
122for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
123for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
124print ($ok ? "ok 8\n" : "not ok 8\n");
125
698828ad 126my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
a0d0e21e 127 $blksize,$blocks) = stat($Dfile);
bee1dbe2
LW
128print ($size > 0 ? "ok 9\n" : "not ok 9\n");
129
130@h{0..200} = 200..400;
698828ad 131my @foo = @h{0..200};
bee1dbe2
LW
132print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
133
134print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
135print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
136
bbad3607 137untie %h;
a0d0e21e 138unlink 'Op.dbmx.dir', $Dfile;
4e2a63a7 139
4e2a63a7
PM
140{
141 # sub-class test
142
143 package Another ;
144
4e2a63a7
PM
145 open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
146 print FILE <<'EOM' ;
147
148 package SubDB ;
149
150 use strict ;
698828ad 151 use warnings ;
4e2a63a7
PM
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 ;
181EOM
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
fac76ed7
MB
205 undef $X;
206 untie(%h);
84902520 207 unlink "SubDB.pm", <dbhash.tmp*> ;
4e2a63a7
PM
208
209}
9fe6733a
PM
210
211{
212 # DBM Filter tests
9fe6733a
PM
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) = @_ ;
1b882d32
GS
219 print "# ", join('|', $fetch_key, $fk, $store_key, $sk,
220 $fetch_value, $fv, $store_value, $sv, $_), "\n";
9fe6733a
PM
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
9fe6733a
PM
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]");
698828ad 364 ok(55, ! defined $result{"fetch value"} );
9fe6733a
PM
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
9fe6733a
PM
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}
9394203c 395
cbc5248d
PM
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
cbc5248d
PM
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
0bf2e707
PM
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
0bf2e707
PM
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
6a31061a
PM
451
452{
453 # Check that DBM Filter can cope with read-only $_
454
6a31061a
PM
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}
0bf2e707 493exit ;
9394203c
JH
494if ($^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#
502EOM
503}