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 / SDBM_File / t / sdbm.t
CommitLineData
a687059c
LW
1#!./perl
2
79072805 3# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
a687059c 4
85e6fe83 5BEGIN {
85e6fe83 6 require Config; import Config;
0468c23b 7 if ($Config{'extensions'} !~ /\bSDBM_File\b/) {
dbb032c1 8 print "1..0 # Skip: no SDBM_File\n";
85e6fe83
LW
9 exit 0;
10 }
11}
698828ad
JH
12
13use strict;
14use warnings;
15
28e5c022 16use Test::More tests => 83;
698828ad 17
8990e307 18require SDBM_File;
a0d0e21e
LW
19#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
20use Fcntl;
a687059c 21
bf99883d 22unlink <Op_dbmx.*>;
79072805 23
a687059c 24umask(0);
698828ad 25my %h ;
b2c10012 26isa_ok(tie(%h, 'SDBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640), 'SDBM_File');
79072805 27
698828ad 28my $Dfile = "Op_dbmx.pag";
79072805 29if (! -e $Dfile) {
89cebecc 30 ($Dfile) = <Op_dbmx*>;
79072805 31}
b2c10012
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' || $^O eq 'dos' || $^O eq 'cygwin';
698828ad 35 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
544a3566 36 $blksize,$blocks) = stat($Dfile);
b2c10012 37 is($mode & 0777, 0640);
544a3566 38}
698828ad
JH
39my $i = 0;
40while (my ($key,$value) = each(%h)) {
a687059c
LW
41 $i++;
42}
b2c10012 43is($i, 0);
a687059c
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
463ee0b2 64untie(%h);
b2c10012 65isa_ok(tie(%h, 'SDBM_File', 'Op_dbmx', O_RDWR, 0640), 'SDBM_File');
a687059c
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);
a687059c 92
b2c10012
NC
93is($#keys, 29);
94is($#values, 29);
a687059c 95
698828ad 96while (my ($key,$value) = each(%h)) {
2f52a358 97 if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
a687059c
LW
98 $key =~ y/a-z/A-Z/;
99 $i++ if $key eq $value;
100 }
101}
102
b2c10012 103is($i, 30);
a687059c 104
c6aa4a32 105@keys = ('blurfl', keys(%h), 'dyick');
b2c10012 106is($#keys, 31);
a687059c 107
fe14fcc3
LW
108$h{'foo'} = '';
109$h{''} = 'bar';
110
698828ad 111my $ok = 1;
a687059c
LW
112for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
113for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
b2c10012 114is($ok, 1, 'check cache overflow and numeric keys and contents');
a687059c 115
698828ad 116my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
79072805 117 $blksize,$blocks) = stat($Dfile);
b2c10012 118cmp_ok($size, '>', 0);
a687059c 119
0f85fab0 120@h{0..200} = 200..400;
698828ad 121my @foo = @h{0..200};
b2c10012 122is(join(':',200..400), join(':',@foo));
fe14fcc3 123
b2c10012
NC
124is($h{'foo'}, '');
125is($h{''}, 'bar');
0f85fab0 126
89cebecc
NC
127is(exists $h{goner1}, '');
128is(exists $h{foo}, 1);
129
130untie %h;
131unlink <Op_dbmx*>, $Dfile;
4e2a63a7 132
4e2a63a7
PM
133{
134 # sub-class test
135
136 package Another ;
137
4e2a63a7
PM
138 open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
139 print FILE <<'EOM' ;
140
141 package SubDB ;
142
143 use strict ;
698828ad 144 use warnings ;
28e5c022 145 use vars qw(@ISA @EXPORT) ;
4e2a63a7
PM
146
147 require Exporter ;
148 use SDBM_File;
149 @ISA=qw(SDBM_File);
28e5c022 150 @EXPORT = @SDBM_File::EXPORT ;
4e2a63a7
PM
151
152 sub STORE {
153 my $self = shift ;
154 my $key = shift ;
155 my $value = shift ;
156 $self->SUPER::STORE($key, $value * 2) ;
157 }
158
159 sub FETCH {
160 my $self = shift ;
161 my $key = shift ;
162 $self->SUPER::FETCH($key) - 1 ;
163 }
164
165 sub A_new_method
166 {
167 my $self = shift ;
168 my $key = shift ;
169 my $value = $self->FETCH($key) ;
170 return "[[$value]]" ;
171 }
172
173 1 ;
174EOM
175
d1e4d418 176 close FILE or die "Could not close: $!";
4e2a63a7
PM
177
178 BEGIN { push @INC, '.'; }
89cebecc 179 unlink <dbhash_tmp*> ;
4e2a63a7
PM
180
181 eval 'use SubDB ; use Fcntl ;';
b2c10012 182 main::is($@, "");
4e2a63a7
PM
183 my %h ;
184 my $X ;
185 eval '
bf99883d 186 $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 );
4e2a63a7
PM
187 ' ;
188
b2c10012 189 main::is($@, "");
4e2a63a7
PM
190
191 my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
b2c10012
NC
192 main::is($@, "");
193 main::is($ret, 5);
4e2a63a7
PM
194
195 $ret = eval '$X->A_new_method("fred") ' ;
b2c10012
NC
196 main::is($@, "");
197 main::is($ret, "[[5]]");
4e2a63a7 198
fac76ed7
MB
199 undef $X;
200 untie(%h);
bf99883d 201 unlink "SubDB.pm", <dbhash_tmp.*> ;
4e2a63a7
PM
202
203}
f4b9d880 204
f4b9d880 205untie %h;
9fe6733a
PM
206unlink <Op_dbmx*>, $Dfile;
207
208{
209 # DBM Filter tests
9fe6733a
PM
210 my (%h, $db) ;
211 my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
212
213 sub checkOutput
214 {
215 my($fk, $sk, $fv, $sv) = @_ ;
216 return
217 $fetch_key eq $fk && $store_key eq $sk &&
218 $fetch_value eq $fv && $store_value eq $sv &&
219 $_ eq 'original' ;
220 }
221
222 unlink <Op_dbmx*>;
b2c10012
NC
223 $db = tie %h, 'SDBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640;
224 isa_ok($db, 'SDBM_File');
9fe6733a
PM
225
226 $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
227 $db->filter_store_key (sub { $store_key = $_ }) ;
228 $db->filter_fetch_value (sub { $fetch_value = $_}) ;
229 $db->filter_store_value (sub { $store_value = $_ }) ;
230
231 $_ = "original" ;
232
233 $h{"fred"} = "joe" ;
234 # fk sk fv sv
b2c10012 235 ok(checkOutput("", "fred", "", "joe"));
9fe6733a
PM
236
237 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
b2c10012 238 is($h{"fred"}, "joe");
9fe6733a 239 # fk sk fv sv
b2c10012 240 ok(checkOutput("", "fred", "joe", ""));
9fe6733a
PM
241
242 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
b2c10012 243 is($db->FIRSTKEY(), "fred");
9fe6733a 244 # fk sk fv sv
b2c10012 245 ok(checkOutput("fred", "", "", ""));
9fe6733a
PM
246
247 # replace the filters, but remember the previous set
248 my ($old_fk) = $db->filter_fetch_key
249 (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
250 my ($old_sk) = $db->filter_store_key
251 (sub { $_ = lc $_ ; $store_key = $_ }) ;
252 my ($old_fv) = $db->filter_fetch_value
253 (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
254 my ($old_sv) = $db->filter_store_value
255 (sub { s/o/x/g; $store_value = $_ }) ;
256
257 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
258 $h{"Fred"} = "Joe" ;
259 # fk sk fv sv
b2c10012 260 ok(checkOutput("", "fred", "", "Jxe"));
9fe6733a
PM
261
262 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
b2c10012 263 is($h{"Fred"}, "[Jxe]");
9fe6733a 264 # fk sk fv sv
b2c10012 265 ok(checkOutput("", "fred", "[Jxe]", ""));
9fe6733a
PM
266
267 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
b2c10012 268 is($db->FIRSTKEY(), "FRED");
9fe6733a 269 # fk sk fv sv
b2c10012 270 ok(checkOutput("FRED", "", "", ""));
9fe6733a
PM
271
272 # put the original filters back
273 $db->filter_fetch_key ($old_fk);
274 $db->filter_store_key ($old_sk);
275 $db->filter_fetch_value ($old_fv);
276 $db->filter_store_value ($old_sv);
277
278 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
279 $h{"fred"} = "joe" ;
b2c10012 280 ok(checkOutput("", "fred", "", "joe"));
9fe6733a
PM
281
282 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
b2c10012
NC
283 is($h{"fred"}, "joe");
284 ok(checkOutput("", "fred", "joe", ""));
9fe6733a
PM
285
286 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
b2c10012
NC
287 is($db->FIRSTKEY(), "fred");
288 ok(checkOutput("fred", "", "", ""));
9fe6733a
PM
289
290 # delete the filters
291 $db->filter_fetch_key (undef);
292 $db->filter_store_key (undef);
293 $db->filter_fetch_value (undef);
294 $db->filter_store_value (undef);
295
296 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
297 $h{"fred"} = "joe" ;
b2c10012 298 ok(checkOutput("", "", "", ""));
9fe6733a
PM
299
300 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
b2c10012
NC
301 is($h{"fred"}, "joe");
302 ok(checkOutput("", "", "", ""));
9fe6733a
PM
303
304 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
b2c10012
NC
305 is($db->FIRSTKEY(), "fred");
306 ok(checkOutput("", "", "", ""));
9fe6733a
PM
307
308 undef $db ;
309 untie %h;
310 unlink <Op_dbmx*>;
311}
312
313{
314 # DBM Filter with a closure
315
9fe6733a
PM
316 my (%h, $db) ;
317
318 unlink <Op_dbmx*>;
b2c10012
NC
319 $db = tie %h, 'SDBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640;
320 isa_ok($db, 'SDBM_File');
9fe6733a
PM
321
322 my %result = () ;
323
324 sub Closure
325 {
326 my ($name) = @_ ;
327 my $count = 0 ;
328 my @kept = () ;
329
330 return sub { ++$count ;
331 push @kept, $_ ;
332 $result{$name} = "$name - $count: [@kept]" ;
333 }
334 }
335
336 $db->filter_store_key(Closure("store key")) ;
337 $db->filter_store_value(Closure("store value")) ;
338 $db->filter_fetch_key(Closure("fetch key")) ;
339 $db->filter_fetch_value(Closure("fetch value")) ;
340
341 $_ = "original" ;
342
343 $h{"fred"} = "joe" ;
b2c10012
NC
344 is($result{"store key"}, "store key - 1: [fred]");
345 is($result{"store value"}, "store value - 1: [joe]");
346 is($result{"fetch key"}, undef);
347 is($result{"fetch value"}, undef);
348 is($_, "original");
349
350 is($db->FIRSTKEY(), "fred");
351 is($result{"store key"}, "store key - 1: [fred]");
352 is($result{"store value"}, "store value - 1: [joe]");
353 is($result{"fetch key"}, "fetch key - 1: [fred]");
354 is($result{"fetch value"}, undef);
355 is($_, "original");
9fe6733a
PM
356
357 $h{"jim"} = "john" ;
b2c10012
NC
358 is($result{"store key"}, "store key - 2: [fred jim]");
359 is($result{"store value"}, "store value - 2: [joe john]");
360 is($result{"fetch key"}, "fetch key - 1: [fred]");
361 is($result{"fetch value"}, undef);
362 is($_, "original");
363
364 is($h{"fred"}, "joe");
365 is($result{"store key"}, "store key - 3: [fred jim fred]");
366 is($result{"store value"}, "store value - 2: [joe john]");
367 is($result{"fetch key"}, "fetch key - 1: [fred]");
368 is($result{"fetch value"}, "fetch value - 1: [joe]");
369 is($_, "original");
9fe6733a
PM
370
371 undef $db ;
372 untie %h;
373 unlink <Op_dbmx*>;
374}
375
376{
377 # DBM Filter recursion detection
9fe6733a
PM
378 my (%h, $db) ;
379 unlink <Op_dbmx*>;
380
b2c10012
NC
381 $db = tie %h, 'SDBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640;
382 isa_ok($db, 'SDBM_File');
9fe6733a
PM
383
384 $db->filter_store_key (sub { $_ = $h{$_} }) ;
385
386 eval '$h{1} = 1234' ;
b2c10012 387 like($@, qr/^recursion detected in filter_store_key at/);
9fe6733a
PM
388
389 undef $db ;
390 untie %h;
391 unlink <Op_dbmx*>;
f4b9d880 392}
9fe6733a 393
cbc5248d
PM
394{
395 # Bug ID 20001013.009
396 #
397 # test that $hash{KEY} = undef doesn't produce the warning
398 # Use of uninitialized value in null operation
cbc5248d
PM
399
400 unlink <Op_dbmx*>;
401 my %h ;
402 my $a = "";
403 local $SIG{__WARN__} = sub {$a = $_[0]} ;
89cebecc 404
b2c10012 405 isa_ok(tie(%h, 'SDBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640), 'SDBM_File');
cbc5248d 406 $h{ABC} = undef;
b2c10012 407 is($a, "");
cbc5248d
PM
408 untie %h;
409 unlink <Op_dbmx*>;
410}
0bf2e707
PM
411
412{
413 # When iterating over a tied hash using "each", the key passed to FETCH
414 # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
415 # key in FETCH via a filter_fetch_key method we need to check that the
416 # modified key doesn't get passed to NEXTKEY.
417 # Also Test "keys" & "values" while we are at it.
418
03fbabc6 419 unlink <Op_dbmx*>;
0bf2e707
PM
420 my $bad_key = 0 ;
421 my %h = () ;
b2c10012
NC
422 my $db = tie %h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640;
423 isa_ok($db, 'SDBM_File');
0bf2e707
PM
424 $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
425 $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
426
427 $h{'Alpha_ABC'} = 2 ;
428 $h{'Alpha_DEF'} = 5 ;
429
b2c10012
NC
430 is($h{'Alpha_ABC'}, 2);
431 is($h{'Alpha_DEF'}, 5);
0bf2e707
PM
432
433 my ($k, $v) = ("","");
434 while (($k, $v) = each %h) {}
b2c10012 435 is($bad_key, 0);
0bf2e707
PM
436
437 $bad_key = 0 ;
438 foreach $k (keys %h) {}
b2c10012 439 is($bad_key, 0);
0bf2e707
PM
440
441 $bad_key = 0 ;
442 foreach $v (values %h) {}
b2c10012 443 is($bad_key, 0);
0bf2e707
PM
444
445 undef $db ;
446 untie %h ;
03fbabc6 447 unlink <Op_dbmx*>;
0bf2e707
PM
448}
449
6a31061a
PM
450{
451 # Check that DBM Filter can cope with read-only $_
452
6a31061a 453 my %h ;
03fbabc6 454 unlink <Op1_dbmx*>;
6a31061a 455
b2c10012
NC
456 my $db = tie %h, 'SDBM_File', 'Op1_dbmx', O_RDWR|O_CREAT, 0640;
457 isa_ok($db, 'SDBM_File');
6a31061a
PM
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" ;
b2c10012 467 is($h{"fred"}, "joe");
6a31061a 468
28e5c022 469 is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
b2c10012 470 is($@, '');
6a31061a
PM
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
b2c10012 481 is($h{"fred"}, "joe");
6a31061a 482
b2c10012 483 is($db->FIRSTKEY(), "fred");
6a31061a 484
28e5c022 485 is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
b2c10012 486 is($@, '');
6a31061a
PM
487
488 undef $db ;
489 untie %h;
03fbabc6 490 unlink <Op1_dbmx*>;
6a31061a 491}