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