This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Convert ext/GDBM_File/t/gdbm.t to Test::More.
[perl5.git] / ext / GDBM_File / t / gdbm.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
LW
6 require Config; import Config;
7 if ($Config{'extensions'} !~ /\bGDBM_File\b/) {
45c0de28 8 print "1..0 # Skip: GDBM_File was not built\n";
a0d0e21e
LW
9 exit 0;
10 }
11}
12
698828ad
JH
13use strict;
14use warnings;
15
77caf3e9 16use Test::More tests => 81;
a0d0e21e
LW
17use GDBM_File;
18
a0d0e21e
LW
19unlink <Op.dbmx*>;
20
bee1dbe2 21umask(0);
698828ad 22my %h ;
77caf3e9 23isa_ok(tie(%h, 'GDBM_File', 'Op.dbmx', GDBM_WRCREAT, 0640), 'GDBM_File');
a0d0e21e 24
698828ad 25my $Dfile = "Op.dbmx.pag";
a0d0e21e
LW
26if (! -e $Dfile) {
27 ($Dfile) = <Op.dbmx*>;
28}
77caf3e9
NC
29SKIP: {
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
698828ad 33 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
544a3566 34 $blksize,$blocks) = stat($Dfile);
77caf3e9 35 is($mode & 0777, 0640);
544a3566 36}
698828ad
JH
37my $i = 0;
38while (my ($key,$value) = each(%h)) {
bee1dbe2
LW
39 $i++;
40}
77caf3e9 41is($i, 0);
bee1dbe2
LW
42
43$h{'goner1'} = 'snork';
44
45$h{'abc'} = 'ABC';
46$h{'def'} = 'DEF';
47$h{'jkl','mno'} = "JKL\034MNO";
48$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
49$h{'a'} = 'A';
50$h{'b'} = 'B';
51$h{'c'} = 'C';
52$h{'d'} = 'D';
53$h{'e'} = 'E';
54$h{'f'} = 'F';
55$h{'g'} = 'G';
56$h{'h'} = 'H';
57$h{'i'} = 'I';
58
59$h{'goner2'} = 'snork';
60delete $h{'goner2'};
61
a0d0e21e 62untie(%h);
77caf3e9 63isa_ok(tie(%h, 'GDBM_File', 'Op.dbmx', GDBM_WRCREAT, 0640), 'GDBM_File');
bee1dbe2
LW
64
65$h{'j'} = 'J';
66$h{'k'} = 'K';
67$h{'l'} = 'L';
68$h{'m'} = 'M';
69$h{'n'} = 'N';
70$h{'o'} = 'O';
71$h{'p'} = 'P';
72$h{'q'} = 'Q';
73$h{'r'} = 'R';
74$h{'s'} = 'S';
75$h{'t'} = 'T';
76$h{'u'} = 'U';
77$h{'v'} = 'V';
78$h{'w'} = 'W';
79$h{'x'} = 'X';
80$h{'y'} = 'Y';
81$h{'z'} = 'Z';
82
83$h{'goner3'} = 'snork';
84
85delete $h{'goner1'};
86delete $h{'goner3'};
87
698828ad
JH
88my @keys = keys(%h);
89my @values = values(%h);
bee1dbe2 90
77caf3e9
NC
91is($#keys, 29);
92is($#values, 29);
bee1dbe2 93
698828ad 94while (my ($key,$value) = each(%h)) {
2f52a358 95 if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
bee1dbe2
LW
96 $key =~ y/a-z/A-Z/;
97 $i++ if $key eq $value;
98 }
99}
100
77caf3e9 101is($i, 30);
bee1dbe2 102
c6aa4a32 103@keys = ('blurfl', keys(%h), 'dyick');
77caf3e9 104is($#keys, 31);
bee1dbe2
LW
105
106$h{'foo'} = '';
107$h{''} = 'bar';
108
698828ad 109my $ok = 1;
bee1dbe2
LW
110for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
111for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
77caf3e9 112is($ok, 1, 'check cache overflow and numeric keys and contents');
bee1dbe2 113
698828ad 114my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
a0d0e21e 115 $blksize,$blocks) = stat($Dfile);
77caf3e9 116cmp_ok($size, '>', 0);
bee1dbe2
LW
117
118@h{0..200} = 200..400;
698828ad 119my @foo = @h{0..200};
77caf3e9 120is(join(':',200..400), join(':',@foo));
bee1dbe2 121
77caf3e9
NC
122is($h{'foo'}, '');
123is($h{''}, 'bar');
bee1dbe2 124
bbad3607 125untie %h;
a0d0e21e 126unlink 'Op.dbmx.dir', $Dfile;
4e2a63a7 127
4e2a63a7
PM
128{
129 # sub-class test
130
131 package Another ;
132
4e2a63a7
PM
133 open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
134 print FILE <<'EOM' ;
135
136 package SubDB ;
137
138 use strict ;
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 ;
168EOM
169
170 close FILE ;
171
172 BEGIN { push @INC, '.'; }
cbc5248d 173 unlink <dbhash.tmp*> ;
4e2a63a7
PM
174
175 eval 'use SubDB ; ';
77caf3e9 176 main::is($@, "");
4e2a63a7
PM
177 my %h ;
178 my $X ;
179 eval '
180 $X = tie(%h, "SubDB","dbhash.tmp", &GDBM_WRCREAT, 0640 );
181 ' ;
182
77caf3e9 183 main::is($@, "");
4e2a63a7
PM
184
185 my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
77caf3e9
NC
186 main::is($@, "");
187 main::is($ret, 5);
4e2a63a7
PM
188
189 $ret = eval ' &GDBM_WRCREAT eq &main::GDBM_WRCREAT ' ;
77caf3e9
NC
190 main::is($@, "");
191 main::is($ret, 1);
4e2a63a7
PM
192
193 $ret = eval '$X->A_new_method("fred") ' ;
77caf3e9
NC
194 main::is($@, "");
195 main::is($ret, "[[5]]");
4e2a63a7 196
fac76ed7
MB
197 undef $X;
198 untie(%h);
84902520 199 unlink "SubDB.pm", <dbhash.tmp*> ;
4e2a63a7
PM
200
201}
9fe6733a
PM
202
203{
204 # DBM Filter tests
9fe6733a
PM
205 my (%h, $db) ;
206 my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
207
208 sub checkOutput
209 {
210 my($fk, $sk, $fv, $sv) = @_ ;
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*>;
77caf3e9
NC
218 $db = tie %h, 'GDBM_File', 'Op.dbmx', GDBM_WRCREAT, 0640;
219 isa_ok($db, 'GDBM_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
77caf3e9 230 ok(checkOutput("", "fred", "", "joe"));
9fe6733a
PM
231
232 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
77caf3e9 233 is($h{"fred"}, "joe");
9fe6733a 234 # fk sk fv sv
77caf3e9 235 ok(checkOutput("", "fred", "joe", ""));
9fe6733a
PM
236
237 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
77caf3e9 238 is($db->FIRSTKEY(), "fred");
9fe6733a 239 # fk sk fv sv
77caf3e9 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
77caf3e9 255 ok(checkOutput("", "fred", "", "Jxe"));
9fe6733a
PM
256
257 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
77caf3e9 258 is($h{"Fred"}, "[Jxe]");
9fe6733a 259 # fk sk fv sv
77caf3e9 260 ok(checkOutput("", "fred", "[Jxe]", ""));
9fe6733a
PM
261
262 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
77caf3e9 263 is($db->FIRSTKEY(), "FRED");
9fe6733a 264 # fk sk fv sv
77caf3e9 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" ;
77caf3e9 275 ok(checkOutput("", "fred", "", "joe"));
9fe6733a
PM
276
277 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
77caf3e9
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 ;
77caf3e9
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" ;
77caf3e9 293 ok(checkOutput("", "", "", ""));
9fe6733a
PM
294
295 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
77caf3e9
NC
296 is($h{"fred"}, "joe");
297 ok(checkOutput("", "", "", ""));
9fe6733a
PM
298
299 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
77caf3e9
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*>;
77caf3e9
NC
314 $db = tie %h, 'GDBM_File','Op.dbmx', GDBM_WRCREAT, 0640;
315 isa_ok($db, 'GDBM_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" ;
77caf3e9
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" ;
77caf3e9
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
77caf3e9
NC
376 $db = tie %h, 'GDBM_File','Op.dbmx', GDBM_WRCREAT, 0640;
377 isa_ok($db, 'GDBM_File');
9fe6733a
PM
378
379 $db->filter_store_key (sub { $_ = $h{$_} }) ;
380
381 eval '$h{1} = 1234' ;
77caf3e9 382 like($@, qr/^recursion detected in filter_store_key at/);
9fe6733a
PM
383
384 undef $db ;
385 untie %h;
386 unlink <Op.dbmx*>;
387}
cbc5248d
PM
388
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]} ;
77caf3e9
NC
399
400 isa_ok(tie(%h, 'GDBM_File', 'Op.dbmx', GDBM_WRCREAT, 0640), 'GDBM_File');
cbc5248d 401 $h{ABC} = undef;
77caf3e9 402 is($a, "");
cbc5248d
PM
403 untie %h;
404 unlink <Op.dbmx*>;
405}
0bf2e707
PM
406
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 = () ;
77caf3e9
NC
417 my $db = tie %h, 'GDBM_File', 'Op.dbmx', GDBM_WRCREAT, 0640;
418 isa_ok($db, 'GDBM_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
77caf3e9
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) {}
77caf3e9 430 is($bad_key, 0);
0bf2e707
PM
431
432 $bad_key = 0 ;
433 foreach $k (keys %h) {}
77caf3e9 434 is($bad_key, 0);
0bf2e707
PM
435
436 $bad_key = 0 ;
437 foreach $v (values %h) {}
77caf3e9 438 is($bad_key, 0);
0bf2e707
PM
439
440 undef $db ;
441 untie %h ;
442 unlink <Op.dbmx*>;
443}
444
6a31061a
PM
445{
446 # Check that DBM Filter can cope with read-only $_
447
6a31061a
PM
448 my %h ;
449 unlink <Op.dbmx*>;
450
77caf3e9
NC
451 my $db = tie %h, 'GDBM_File', 'Op.dbmx', GDBM_WRCREAT, 0640;
452 isa_ok($db, 'GDBM_File');
453
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" ;
77caf3e9 463 is($h{"fred"}, "joe");
6a31061a 464
f84167b3 465 eval { my @r= grep { $h{$_} } (1, 2, 3) };
77caf3e9 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
77caf3e9 477 is($h{"fred"}, "joe");
6a31061a 478
77caf3e9 479 is($db->FIRSTKEY(), "fred");
6a31061a 480
f84167b3 481 eval { my @r= grep { $h{$_} } (1, 2, 3) };
77caf3e9 482 is($@, '');
6a31061a
PM
483
484 undef $db ;
485 untie %h;
486 unlink <Op.dbmx*>;
487}